VBA用于合并和转移细胞范围分组

Question

不确定如何用文字表达，但基本上是从WorkBook1的sheet1运行宏，它应该生成一个像WorkBook2的sheet1。 （WB2 Sheet1为空）

诀窍是宏应该只适用于用户选择的范围 因此，如果选择A1：A7，它将仅从A1：A7获取数据到数据
的最后一列 如果未选择任何内容，则使用msgbox或

退出sub

订单/排序无关紧要，只要它合并XYs重复项并将各自的水果组合在一起即可。

   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，但这会让你开始。