关于vba：几个工作表的Excel列-复制，排序，超链接

Excel columns of several worksheets - copy, sort, hyperlink

需要以下帮助：

我有几个具有相同结构的工作表，并且在每个工作表中我都有两列(我们称它们为X

尝试一下。将其粘贴到模块中并运行Sub Sample。

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111

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