Question

需要以下方面的帮助：

我有几个具有相同结构的工作表，在每个工作表中我有两列（我们称之为X＆amp; Y），我需要使用它们的单元格值（字母数字组合）进行复制，并复制Column 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

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

更新：

我忘了提到X＆amp; Y永远是彼此相邻的。

示例：

Sheet1：

|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，并对Sheet2中的X进行ColQ

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

两张纸的输出： |科利|可乐| COLB | COLC |冷| 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

几列工作表的Excel列 - 复制，排序，超链接

1 个答案: