我将此宏设置为复制到同一工作簿的 sheet2。要保存到新工作簿,只需使用您的工作簿名称而不是 activeworkbook 更新以下代码行。
Set sheetB = ActiveWorkbook.Sheets("Sheet2")
从表 1 中的以下数据和空白表 2 开始:
选择 A1 到 A8 并运行此宏:
Sub CopyAndFormat()
If IsEmpty(Selection) Then
MsgBox ("Empty Cell")
Exit Sub
End If
Dim sheet As Worksheet
Set sheetA = ActiveWorkbook.Sheets("Sheet1")
Set sheetB = ActiveWorkbook.Sheets("Sheet2")
Dim FirstRow As Long, LastRow As Long
FirstRow = Selection.Rows(1).Row
LastRow = Selection.Rows.Count + FirstRow - 1
'First Column
Dim rngA As Range
Set rngA = Range("A" & FirstRow & ":A" & LastRow)
Dim datA As Variant
datA = rngA
Dim i As Long
'Second Column Match
Dim rngB As Range
Set rngB = Range("B" & FirstRow & ":B" & LastRow)
Dim datB As Variant
datB = rngB
Dim j As Long
Dim resultA As Variant
Dim resultB As Variant
Dim rng As Range
Dim rngr As Range
Set rng = sheetB.Range("A1:A" & LastRow + 100)
Set rngr = sheetB.Range("B1:B" & LastRow + 100)
resultA = rng
resultB = rngr
'Store duplicates
Dim rngString As String
rngString = "empty"
Dim match As Boolean
match = False
Dim cntr As Integer
cntr = 1
'First Column loop
For i = LBound(datA, 1) To UBound(datA, 1)
If rngString <> "empty" Then
If Not Intersect(Range("A" & i), Range(rngString)) Is Nothing Then
GoTo nextloop
End If
End If
'Second Column Loop
For j = LBound(datA, 1) + i To UBound(datA, 1)
If i <> j And datA(i, 1) = datA(j, 1) And Not IsEmpty(datA(j, 1)) And Not IsEmpty(datA(i, 1)) Then
'copy position of duplicate in variant
If rngString = "empty" Then
match = True
resultA(cntr, 1) = datA(i, 1)
resultB(cntr + 1, 1) = datB(i, 1)
resultB(cntr + 1, 1) = datB(i, 1)
resultB(cntr + 2, 1) = datB(j, 1)
rngString = "A" & i & ",A" & j
cntr = cntr + 2
Else
resultB(cntr + 1, 1) = datB(j, 1)
cntr = cntr + 1
rngString = rngString & "," & "A" & j
End If
End If
Next
If match = False Then
resultA(cntr + 1, 1) = datA(i, 1)
resultB(cntr + 2, 1) = datB(i, 1)
cntr = cntr + 2
End If
match = False
'cntr = cntr + 1
nextloop:
Next
rng = resultA
rngr = resultB
End Sub
您将在 sheet2 上获得以下信息:
抱歉,代码有点乱,我讨厌使用 goto,但这会让你开始。