vba - VBA 通过合并和分组传输单元格范围

Question

不知道如何用语言表达，但基本上宏是从 WorkBook1 的 sheet1 运行的，它应该产生一个类似于 WorkBook2 的 sheet1 的宏。（WB2 Sheet1 为空）

诀窍是宏应该只适用于用户选择的范围。
因此，如果选择 A1:A7，它只会从 A1:A7 抓取数据到最后一列的数据
如果没有选择任何内容，则使用 msgbox 或其他东西退出 sub

排序/排序无关紧要，只要它合并 XY 重复项并将相应的水果组合在一起即可。

   A      B      =>     A     B      C
1 XY3   Apple    =>  1  H    XY1    
2 XY1   Orange   =>  2  D          Orange
3 XY3   Banana   =>  3  H    XY2   
4 XY3   Banana   =>  4  D          Orange
5 XY3   Peach    =>  5  H    XY3      
6 XY4   Orange   =>  6  D          Apple
7 XY2   Orange   =>  7  D          Banana
8 XY7   Apple    =>  8  D          Banana
                 =>  9  D          Peach
                 => 10  H    XY4    
                 => 11  D          Orange
 [WB1 Sheet1]    =>      [WB2 Sheet1]

这可能很困难，但我正在拼命寻求帮助。
非常感谢！

Answer 1

我将此宏设置为复制到同一工作簿的 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，但这会让你开始。