Question

我有一个看起来像这样的巨型数据集

enter image description here

我试图将不同公司的名单列入其中，每家公司获得3个并将它们合并。根据上面的照片，我将有2个不同的列表，每个列表有3个公司（除了TH修复，最终列表中有2个）。

我的真实数据集包含数百个不同的公司，每个公司都有数十个/数百个条目，因此我将完成几十个列表（每个列表可能有数百个）。

我尝试录制宏并最终使用此代码

Sub Loop1()
'
' Loop1 Macro
'

'
    Range("A4:E6").Select
    Selection.Copy
    Sheets("Sheet3").Select
    Range("A18").Select
    ActiveSheet.Paste
    Sheets("Sheet2").Select
    Range("A11:E13").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet3").Select
    Range("A21").Select
    ActiveSheet.Paste
    Sheets("Sheet2").Select
    Range("A17:E19").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("Sheet3").Select
    Range("A24").Select
    ActiveSheet.Paste
End Sub

然而，事实证明这比我预期的要复杂得多。

我正在寻找最终结果看起来像这样

enter image description here

Answer 1

看看这样的东西是否适合你。我只通过它运行了一个场景，所以你想要更多地测试它。

这假设数据按原始工作表上的B列排序
此过程假设第1行有标题或没有数据。

您需要将此行Set ws1 = ActiveWorkbook.Worksheets("Sheet1")中的“Sheet1”更改为您开始使用的工作表的名称。

Option Explicit

Public Sub MoveData()

    Dim ws1 As Worksheet
    Set ws1 = ActiveWorkbook.Worksheets("Sheet1")

    Dim ws2 As Worksheet
    Set ws2 = ActiveWorkbook.Worksheets.Add()


    Dim rw As Long
    Dim match_count As Integer
    Dim list_multiplier As Integer
    list_multiplier = 7
    Dim list_row() As Long
    ReDim list_row(0)
    list_row(0) = 2

    For rw = 2 To ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row


        If ws1.Range("B" & rw).Value <> ws1.Range("B" & rw).Offset(-1, 0).Value Then
            match_count = 0
        Else
            match_count = match_count + 1
        End If

        Dim list_num As Integer
        list_num = match_count \ 3

        If list_num > UBound(list_row, 1) Then
            ReDim Preserve list_row(list_num)
            list_row(list_num) = 2
        End If

        ws2.Cells(list_row(list_num), 1 + list_multiplier * list_num).Value = ws1.Range("A" & rw).Value
        ws2.Cells(list_row(list_num), 2 + list_multiplier * list_num).Value = ws1.Range("B" & rw).Value
        ws2.Cells(list_row(list_num), 3 + list_multiplier * list_num).Value = ws1.Range("C" & rw).Value
        ws2.Cells(list_row(list_num), 4 + list_multiplier * list_num).Value = ws1.Range("D" & rw).Value
        ws2.Cells(list_row(list_num), 5 + list_multiplier * list_num).Value = ws1.Range("E" & rw).Value
        list_row(list_num) = list_row(list_num) + 1

    Next rw

End Sub

Answer 2

录制宏时，请确保＆＃34;使用相对参考＆＃34;在Developer Ribbon选项卡上启用，:)）

Answer 3

假设第3行包含您的数据标题，您可以尝试这样做：

Option Explicit

Sub main()
    Dim nLists As Long, iList As Long
    Dim data As Variant
    Dim dataToDelete As Range

    With Range("F3", Cells(Rows.Count, 1).End(xlUp))
        data = .Value
        nLists = WorksheetFunction.Max(.Resize(,1))
        nLists = nLists \ 3 + IIf(nLists - 3 * (nLists \ 3) = 0, -1, 0)
    End With

    With Range("A3").Resize(, 6)
        For iList = 0 To nLists
            Set dataToDelete = Nothing
            With .Offset(, iList * 6).Resize(UBound(data))
                .Value = data
                .AutoFilter Field:=1, Criteria1:="<=" & iList * 3, Criteria2:=">" & (iList + 1) * 3, Operator:=xlOr
                If Application.WorksheetFunction.Subtotal(103, .Cells) > 1 Then Set dataToDelete = .Offset(1).Resize(.Rows.Count - 1).SpecialCells(xlCellTypeVisible)
                .Parent.AutoFilterMode = False
                If Not dataToDelete Is Nothing Then dataToDelete.Delete xlShiftUp
            End With
        Next
    End With
End Sub

Answer 4

您的任务实际上比您的在线建议略显复杂。基本上，您必须执行以下操作：

找出有多少独特的钥匙＆＃39; （即B栏中的唯一项目）。这将告诉您所需的总行数（即唯一键数* 3）
计算每个键的项目数＆＃39;。这将告诉您需要多少列（即最大项目数/ 3 *数组中的列数[A：E = 5]）
循环遍历每一行数据，并将其放在适当的行上，以便键入＆＃39;键。到达三个后，将该键的列向右跳6列，然后继续。

如果您要使用Class对象和Collection类型的对象，这可能是非常简洁的代码，但是根据您的帖子判断，您正处于VBA编程之旅的开始阶段。因此，我已将每个任务分解为单独的代码块，因此您希望看到数组如何为您工作。一旦你练习了一些数组，也许你可以通过组合一些循环来提高这段代码的效率：

Public Sub RunMe()
    Dim data As Variant
    Dim r As Long, c As Long, i As Long, dataRows As Long, dataCols As Long, keyLen As Long, maxCount As Long
    Dim keys As String
    Dim k As Variant
    Dim keyArray() As String
    Dim keyCount() As Long, threeCount() As Long, rowNum() As Long, colNum() As Long
    Dim output() As Variant

    'Read the data - change "Sheet1" to your sheet name.
    'Shows how to write range values into a variant to
    'create an array of variants.
    data = ThisWorkbook.Worksheets("Sheet1").UsedRange.Value2
    dataRows = UBound(data, 1)
    dataCols = UBound(data, 2)

    'Create a list of unique keys.
    'Note: not the most efficient way, but shows how to
    'create an array from a value-separated string.
    For r = 1 To dataRows
        If InStr(keys, CStr(data(r, 2))) = 0 Then
            If Len(keys) > 0 Then keys = keys & "|"
            keys = keys & CStr(data(r, 2))
        End If
    Next
    keyArray = Split(keys, "|")
    keyLen = UBound(keyArray)

    'Initialise the row and column numbers for each key.
    'Shows how to iterate an array using For Each loop.
    ReDim rowNum(keyLen)
    ReDim colNum(keyLen)
    r = 1
    i = 0
    For Each k In keyArray
        rowNum(i) = r
        colNum(i) = 1
        r = r + 3
        i = i + 1
    Next

    'Count the number of items for each key.
    'Shows how to iterate an array using For [index] loop.
    ReDim keyCount(keyLen)
    For r = 1 To dataRows
        i = IndexOfKey(keyArray, CStr(data(r, 2)))
        keyCount(i) = keyCount(i) + 1
        If keyCount(i) > maxCount Then maxCount = keyCount(i)
    Next

    'Size the output array.
    c = WorksheetFunction.Ceiling(maxCount / 3, 1)
    ReDim output(1 To (keyLen + 1) * 3, 1 To c * dataCols + c - 1)

    'Populate the output array.
    ReDim threeCount(keyLen)
    For r = 1 To dataRows
        i = IndexOfKey(keyArray, CStr(data(r, 2)))
        'Copy the columns for this row.
        For c = 1 To dataCols
            output(rowNum(i), colNum(i) + c - 1) = data(r, c)
        Next
        'Increment the count and if it's equals 3 then
        'reset the row num and increase the column number.
        threeCount(i) = threeCount(i) + 1
        rowNum(i) = rowNum(i) + 1
        If threeCount(i) = 3 Then
            rowNum(i) = rowNum(i) - 3
            colNum(i) = colNum(i) + dataCols + 1
            threeCount(i) = 0
        End If
    Next

    'Write the data - change "Sheet2" to your sheet name.
    'Shows how to write an array to a Range.
    ThisWorkbook.Worksheets("Sheet2").Range("A3") _
        .Resize(UBound(output, 1), UBound(output, 2)).Value = output
End Sub

Private Function IndexOfKey(list() As String, key As String) As Long
    Dim i As Long
    Dim k As Variant

    'Helper function to find index position of key in array.
    For Each k In list
        If key = k Then
            IndexOfKey = i
            Exit Function
        End If
        i = i + 1
    Next

    IndexOfKey = -1
End Function

在抓取某些元素时循环遍历数组

4 个答案: