Excel columns of several worksheets - copy, sort, hyperlink - vba

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