Question

Need some help with the following:

I have several worksheets with the same structure and within each worksheet I have two columns (let’s call them X & Y) that I need to copy with their cellvalues (letter-number combination) and also copy the values of Column A-F to an own sheet for X and Y.

On the “new” sheet I want to put X/Y to column A sort the values after A and attach a constant hyperlink to each cellvalue in A.
So X or Y goes to A and A-F to B-G.

Then I want to make column F or the new G clickable so that it will take me to the row in the according worksheet.
X and Y don’t always happen to be in column X or Y but I think this can be solved with a “name search”.

When I execute my code then for example worksheet3 will overwrite the values of worksheet1 and my hyperlink structure is wrong too. The sorting is left out since that is working.

Function CopyAndSort(ByRef mySheet As Worksheet)
'   If mySheet.Name <> "Sheet1" Then
'   Exit Function
'   End If

   mySheet.Activate
    Set sheetCS = Sheets("CopyAndSort Sheet")
    sheetCS.Range("A:A").Value = ""
   lastRowCS = Range("X:X").Cells.Find("*", , , , , xlPrevious).Row

     rowNumber = 1
    For rowCopy = 5 To lastRowFO
        sheetCopy = Range("BE" & rowCopy)
        If Trim(sheetCopy) <> "" Then
            sheetCopy = Replace(sheetCopy, """", "")
            If InStr(1, sheetCopy, ",", vbTextCompare) <> 0 Then
               sheetCopyArray = Split(sheetCopy, ",")
            Else
               sheetCopyArray = Array(sheetCopy)
      End If

            For Each copy In sheetCopyArray

                rowNumber = rowNumber + 1

                        copy_Value = copy
' test for url                         
'  sheetCS.Cells(rowNumber, 1).Formula = "=HYPERLINK(""ConstURL & copyValue"")"

                     sheetCS.Cells(rowNumber, 1) = copy_Value
                        copy_Value = Cells(rowCopy, 1)
                            sheetCS.Cells(rowNumber, 2) = copy_Value
                        copy_Value = Cells(rowCopy, 2)
                            sheetCS.Cells(rowNumber, 3) = copy_Value
                        copy_Value = Cells(rowCopy, 3)
                            sheetCS.Cells(rowNumber, 4) = copy_Value
                            copy_Value = Cells(rowCopy, 4)
                            sheetCS.Cells(rowNumber, 5) = copy_Value
                        copy_Value = Cells(rowCopy, 5)
                            sheetCS.Cells(rowNumber, 6) = copy_Value

            Next
        End If

    Next 

So how can I manage to not overwrite the values and attach the correct hyperlink syntax, plus making colum G clickable?
And can I use one function for X and Y?
Some code examples would help me alot.
Thank you.

UPDATE:

i forgot to mention that X & Y will always be next to each other.

Example:

Sheet1:

|ColA|ColB|ColC|ColD|ColF|....|ColX|ColY|

Sheet2: here “ColX” is in ColQ and ColY in ColR

|ColA|ColB|ColC|ColD|ColF|....|ColXinColQ|ColYinColR|

CopySheet_of_X: now copy ColX plus ColA-ColF of Sheet1 and do the same for Sheet2 where X is in ColQ

Output for both sheets:
|ColX|ColA|ColB|ColC|ColD|ColF|

CopySheet_of_Y: now copy ColY plus ColA-ColF of Sheet1 and do the same for Sheet2 where Y is in ColR

Output for both sheets:
|ColY|ColA|ColB|ColC|ColD|ColF|

Hyperlink:
so now the values of ColX and ColY should be concatenated with a preceding hyperlink:
If a cell in ColX has the value of “someValue1” then it should be turned into myurl://sometext=someValue1

and I don’t know the right way to jump back to the row when clicking on ColF.

Answer 1

Try this. Paste this in a module and run Sub Sample.

Option Explicit

Const hLink As String = "d3://d3explorer/idlist="

Sub Sample()
    Dim sheetsToProcess

    Set sheetsToProcess = Sheets(Array("Sheet1", "Sheet2"))

    CopyData sheetsToProcess, "CopySheet_of_X", "FirstLinkValue"

    '~~> Similarly for Y
    'CopyData sheetsToProcess, "CopySheet_of_Y", "SecondLinkValue"
End Sub

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
'                      USAGE                         '
' wsI      : Worksheet Collection                    '
' wsONm    : name of the new sheet for output        '
' XY       : Name of the X or Y Header               '
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Sub CopyData(wsI, wsONm As String, XY As String)
    Dim ws As Worksheet, sSheet As Worksheet
    Dim aCell As Range
    Dim lRow As Long, LastRow As Long, lCol As Long, i As Long, j As Long
    Dim MyAr() As String

    '~~> Delete the Output sheet if it is already there
    On Error Resume Next
    Application.DisplayAlerts = False
    Sheets(wsONm).Delete
    Application.DisplayAlerts = True
    On Error GoTo 0

    '~~> Recreate the output sheet
    Set ws = Sheets.Add: ws.Name = wsONm

    '~~> Create Headers in Output Sheet
    ws.Range("A1") = XY
    wsI(1).Range("A3:F3").Copy ws.Range("B1")

    '~~> Loop throught the sheets array
    For Each sSheet In wsI
        LastRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row + 1
        With Sheets(sSheet.Name)
            '~~> Find the column which has X/Y header
            Set aCell = .Rows(3).Find(What:=XY, LookIn:=xlValues, _
            LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False)

            If aCell Is Nothing Then
                '~~> If not found, inform and exit
                MsgBox XY & " was not found in " & .Name, vbCritical, "Exiting Application"
                Exit Sub
            Else
                '~~> if found then get the column number
                lCol = aCell.Column

                '~~> Identify the last row of the sheet
                lRow = .Range("A" & .Rows.Count).End(xlUp).Row

                '~~> Loop through the X Column and split values
                For i = 4 To lRow
                    If InStr(1, .Cells(i, lCol), ",") Then '<~~ If values like A1,A2,A3
                        MyAr = Split(.Cells(i, lCol), ",")

                        For j = 0 To UBound(MyAr)
                            '~~> Add hyperlink in Col 1
                            With ws
                                .Cells(LastRow, 1).Value = MyAr(j)
                                .Hyperlinks.Add Anchor:=.Cells(LastRow, 1), Address:= _
                                hLink & .Cells(LastRow, 1).Value, TextToDisplay:=.Cells(LastRow, 1).Value
                            End With

                            .Range("A" & i & ":F" & i).Copy ws.Range("B" & LastRow)

                            '~~> Add hyperlink in Col 2
                            With ws
                                .Hyperlinks.Add Anchor:=.Cells(LastRow, 7), Address:="", SubAddress:= _
                                sSheet.Name & "!" & "A" & i, TextToDisplay:=.Cells(LastRow, 7).Value
                            End With

                            LastRow = LastRow + 1
                        Next j
                    Else  '<~~ If values like A1
                        '~~> Add hyperlink in Col 1
                        With ws
                            .Cells(LastRow, 1).Value = Sheets(sSheet.Name).Cells(i, lCol)
                            .Hyperlinks.Add Anchor:=.Cells(LastRow, 1), Address:= _
                            hLink & .Cells(LastRow, 1).Value, TextToDisplay:=.Cells(LastRow, 1).Value
                        End With

                        .Range("A" & i & ":F" & i).Copy ws.Range("B" & LastRow)

                        '~~> Add hyperlink in Col 2
                        With ws
                            .Hyperlinks.Add Anchor:=.Cells(LastRow, 7), Address:="", SubAddress:= _
                            sSheet.Name & "!" & "A" & i, TextToDisplay:=.Cells(LastRow, 7).Value
                        End With

                        LastRow = LastRow + 1
                    End If
                Next i
            End If
        End With
    Next

    '~~> Sort the data
    ws.Columns("A:G").Sort Key1:=ws.Range("A2"), Order1:=xlAscending, Header:=xlGuess, _
    OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
End Sub