在抓取某些元素的同时循环访问数组

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

我正在试图列出不同的公司名单，并且每个公司拿3个并且结合起来。 根据上面的照片，我会有两个不同的名单，每个公司有三家（除了最后名单上有两个的TH修理公司）。

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

我试图logging一个macros，并结束了这个代码

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 

然而，事实certificate，这是更复杂，然后我预料。

我正在寻找这样的最终结果

Answer 1

看看这样的事情是否适合你。 我只通过它跑了一个场景，所以你会想testing更多。

• 这就假定数据按原始表格中的B列sorting
• 此过程假定第1行上有标题或没有数据。

• 您将需要更改此行中的“Sheet1” Set ws1 = ActiveWorkbook.Worksheets("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

当您录制macros时，请确保已启用开发者function区选项卡上的“使用相对引用”，:)

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

你的任务实际上比你的在线build议稍微复杂一些。 基本上，你必须做到以下几点：

1. 找出有多less个唯一的“键”（即B列中的唯一项）。 这将告诉你你需要的总行数（即唯一键的数量* 3）
2. 计算每个“键”的项目数量。 这将告诉你你需要多less列（例如最大项目数/ 3 *列数[A：E = 5]）
3. 循环遍历每行数据，并将其放在适当的行上。 一旦达到了三个，将该列的列向右跳6列，然后继续。

如果你要使用Class对象和Collectiontypes的对象，这可能是非常简洁的代码，但是从你的post来看，你是在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