多个工作表的 Excel 列 - 复制、排序、超链接

Question

在以下方面需要一些帮助：

我有几个具有相同结构的工作表，在每个工作表中我有两列（我们称它们为 X 和 Y），我需要使用它们的单元格值（字母数字组合）复制它们，并将 AF 列的值复制到X 和 Y 的自己的工作表。

在“新”工作表上，我想将 X/Y 放入 A 列，对 A 之后的值进行排序，并为 A 中的每个单元格值附加一个常量超链接。 所以 X 或 Y 到 A，A-F 到 B-G。

然后我想让列 F 或新的 G 可点击，以便将我带到相应工作表中的行。 X 和 Y 并不总是恰好在 X 或 Y 列中，但我认为这可以通过“名称搜索”来解决。

当我执行我的代码时，例如 worksheet3 将覆盖 worksheet1 的值，我的超链接结构也是错误的。排序被忽略了，因为它正在工作。

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 

那么我怎样才能设法不覆盖这些值并附加正确的超链接语法，并使列 G 可点击？ 我可以对 X 和 Y 使用一个函数吗？ 一些代码示例会对我有很大帮助。 谢谢。

更新：

我忘了说 X 和 Y 永远是相邻的。

例子：

表 1：

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

Sheet2：这里“ColX”在 ColQ 中，ColY 在 ColR 中

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

CopySheet_of_X：现在复制 Sheet1 的 ColX 和 ColA-ColF 并对 X 在 ColQ 中的 Sheet2 执行相同操作

两张表的输出： |ColX|ColA|ColB|ColC|ColD|ColF|

CopySheet_of_Y：现在复制 Sheet1 的 ColY 和 ColA-ColF，并对其中 Y 在 ColR 中的 Sheet2 执行相同操作

两张表的输出： |ColY|ColA|ColB|ColC|ColD|ColF|

超链接： 所以现在 ColX 和 ColY 的值应该与前面的超链接连接： 如果 ColX 中的单元格具有“someValue1”的值，则应将其转换为 myurl://sometext=someValue1

而且我不知道单击 ColF 时跳回该行的正确方法。

Answer 1

试试这个。将其粘贴到模块中并运行 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