復制粘貼行，直到 B 列中的值更改到另一個工作表中的下一個空列

Question

我在Excel Sheet1中有一個數據，如下：

我必須組織數據，我想將基於“B 列”的所有數據行復制到單獨的工作表中，直到“B 列”中的最后一個唯一值，如下所示： 我的數據集中大約有 6000 行.

我開發了以下 VBA 代碼，它每 6 行復制一次並將其粘貼到 Sheet2 的最后一個空列中。 如下所示。

Sub copyPaste()

    Dim x As Long
    Dim y As Long
    Dim lastRow As Long

    Dim sht As Worksheet
    Set sht = Worksheets("Sheet1")
    
    y = 6
    lastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
    'emptyColumn = Sheet2.Cells(2, Columns.Count).End(xlToLeft).Column

    For x = 2 To lastRow Step 6
        If Worksheets("Sheet2").Cells(2, "A") = "" Then
            Worksheets("Sheet1").Range("A" & x & ":D" & y).Copy _
                    Destination:=Worksheets("Sheet2").Cells(2, "A")
        Else
            Worksheets("Sheet1").Range("A" & x & ":D" & y).Copy _
                    Destination:=Worksheets("Sheet2").Cells(2, Columns.Count).End(xlToLeft).Offset(, 1)
        End If
        y = y + 6
    Next
End Sub

如上圖 2 所示，我懇請你們是否有組織數據的解決方案。

Answer 1

假設您的數據按 Person 排序：

Sub copyPaste()
    Dim wsSource As Worksheet, cDest As Range, c As Range, n As Long
    
    Set wsSource = Worksheets("Sheet1")            'source data sheet
    Set c = wsSource.Range("B2")                   'first person name
    
    Set cDest = Worksheets("Sheet2").Range("A1")   'first paste destination
    
    Do While c.Value <> ""                                      'loop while have a name
        n = Application.CountIf(wsSource.Columns("B"), c.Value) 'how many rows for this person?
        c.Offset(0, -1).Resize(n, 4).Copy cDest                 'copy data over
        Set c = c.Offset(n)                                     'next name
        Set cDest = cDest.Offset(0, 4)                          'next paste location
    Loop
End Sub

Answer 2

並排堆疊唯一行

• 如果復制值（無格式或公式）足夠好，您可以使用以下內容。

Option Explicit

Sub StackUniqueRowsSideBySide()
    
    ' Reference the workbook.
    Dim wb As Workbook: Set wb = ThisWorkbook
    
    ' Reference the source worksheet ('sws').
    Dim sws As Worksheet: Set sws = wb.Worksheets("Sheet1")
    
    Dim srg As Range
    
    ' Reference the source range.
    With sws.Range("A1").CurrentRegion
        Set srg = .Resize(.Rows.Count - 1).Offset(1)
    End With
    
    ' Using the 'GetUniqueRowsSideBySide' function,
    ' return the stacked unique rows in a 2D one-based array ('dData').
    Dim dData As Variant: dData = GetUniqueRowsSideBySide(srg, 3, 0)
    
    ' Reference the destination worksheet ('dws').
    Dim dws As Worksheet: Set dws = wb.Worksheets("Sheet2")
    
    ' Reference the destination first cell ('dfCell').
    Dim dfCell As Range: Set dfCell = dws.Range("A2")
        
    Dim drg As Range
        
    ' Reference the destination clear range ('drg').
    Set drg = dfCell.Resize(dws.Rows.Count - dfCell.Row + 1, _
        dws.Columns.Count - dfCell.Row + 1)
    ' Clear previous data.
    drg.Clear
    
    ' Reference the destination range ('drg').
    Set drg = dfCell.Resize(UBound(dData, 1), UBound(dData, 2))
    ' Write new data.
    drg.Value = dData

End Sub

Function GetUniqueRowsSideBySide( _
    ByVal srg As Range, _
    Optional ByVal UniqueColumn As Long = 1, _
    Optional ByVal ColumnGap As Long = 0) _
As Variant
    
    ' Write the number of source rows and columns
    ' to variables ('srCount', 'scCount').
    Dim srCount As Long: srCount = srg.Rows.Count
    Dim scCount As Long: scCount = srg.Columns.Count
    
    ' Write the values from the source range to a 2D one-based array,
    ' the source array ('sData').
    Dim sData() As Variant: sData = srg.Value
    
    ' Create and reference a new dictionary object ('dict').
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare ' case-insensitive
    
    Dim sKey As Variant
    Dim sr As Long
    
    ' Write each unique value from the unique column ('UniqueColumn')
    ' of the source array to a 'key' of the dictionary and write
    ' the current row to the collection held in the associated 'item'.
    For sr = 1 To srCount
        sKey = sData(sr, UniqueColumn)
        If Not dict.Exists(sKey) Then
            Set dict(sKey) = New Collection
        End If
        dict(sKey).Add sr
    Next sr
            
    Dim drCount As Long
    
    ' Determine the destination rows count ('drCount'),
    ' the number of items in the largest collection ('dict(sKey)').
    For Each sKey In dict.Keys
        If dict(sKey).Count > drCount Then drCount = dict(sKey).Count
    Next sKey
    
    ' Calculate the destination columns count ('drCount').
    Dim dcCount As Long
    dcCount = dict.Count * (scCount + ColumnGap) - ColumnGap
    
    ' Define the destination array ('dData').
    Dim dData() As Variant: ReDim dData(1 To drCount, 1 To dcCount)
     
    Dim sItem As Variant
    Dim sk As Long
    Dim sc As Long
     
    Dim dr As Long
    Dim dcOffset As Long
     
    ' Using the information in the dictionary, return the stacked unique rows
    ' from the source array in the destination array.
    For Each sKey In dict.Keys
        sk = sk + 1
        dcOffset = (sk - 1) * (scCount + ColumnGap)
        For Each sItem In dict(sKey)
            dr = dr + 1
            For sc = 1 To scCount
                dData(dr, sc + dcOffset) = sData(sItem, sc)
            Next sc
        Next sItem
        dr = 0
    Next sKey
    
    ' Assign the destination array to the result of the function.
    GetUniqueRowsSideBySide = dData
    
End Function