使用VBA在Excel中收集数据

情况如何：

所以我得到了一个excel格式的“结果样本”，需要过滤和重塑，看起来不错。 这是一个总是不一样的结果，但它遵循类似的规则。 我必须进一步过滤，并使之更加整洁。 我已经找出了过滤部分，但我不知道如何整理剩余的数据。

情况是什么：

有六列涉及。

注意：真正的交易并不那么简单，但是我需要的东西可以用这样一个简单的例子来演示，然后我可以自己pipe理更复杂的东西。

对于我们的例子，我们使用从B到G的列。数据被设置为“标题”和值的对。 例如，如果你看看我提供的第一个例子，第一个例子是B3和C3。

正如你所看到的，看着相同的图片，D3和E3是一个空对。 D4 – E4和F4 – G4等，直到B11 – C11的最后一个。 开始数据示例：

[

我想实现的是：

我想使用Visual Basic for Applications对数据进行sorting，从我们的例子B3开始（参见第二张图片），并填充两列（BC，DE，FG）中的三个SET，如果这些列中没有数据细胞。

注意：如果D3这样的单元为空，那么SUR3 E3也将为空，因此只能有一个检查。 我的意思是我们可以检查任何值列或标题列。

注意2：B，D，F或C，E，G列不必分类。 我只是想把B，D，F的所有非空值和C，E，G各自的值集中在一起，这样打印就不需要30页，而只需要几页（间隔太多了，自动清理）

Answer 1

这里有一些开始。 第一个双循环使用指向包含标题的单元格的范围variables填充VBA集合。 相关的值是通过使用偏移量获得的。 中间双循环对后者执行冒泡sorting（效率非常低 – 您可能想用其他方法replace它）。 下一个if语句创build第二个工作表，如果它不存在，则在其上写出结果（最后一个循环）。

Option Explicit Sub GatherData() Dim lastRow As Integer, lastCol As Integer Dim r As Integer, c As Integer Dim vals As Collection Set vals = New Collection With Sheets(1) lastCol = .UsedRange.Columns(.UsedRange.Columns.Count).Column lastRow = .UsedRange.Rows(.UsedRange.Rows.Count).row For c = 1 To lastCol Step 2 For r = 1 To lastRow If (Trim(Cells(r, c).Value) <> "") Then vals.Add .Cells(r, c) End If Next Next End With ' Bubble Sort Dim i As Integer, j As Integer Dim vTemp As Range For i = 1 To vals.Count - 1 For j = i + 1 To vals.Count If vals(i).Value > vals(j).Value Then Set vTemp = vals(j) vals.Remove j vals.Add vTemp, vTemp, i End If Next j Next i Dim sht2 As Worksheet If ThisWorkbook.Worksheets.Count = 1 Then Set sht2 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(1)) Else Set sht2 = Worksheets(2) End If With sht2 r = 3 c = 2 For i = 1 To vals.Count .Cells(r, c).Value = vals(i).Value .Cells(r, c + 1).Value = vals(i).Offset(, 1).Value c = c + 2 If c = 8 Then r = r + 1 c = 2 End If Next End With End Sub 

Answer 2

这是一个使用Dictionary对象的方法。 我使用早期绑定，它需要设置对Microsoft脚本运行时的引用。 如果你打算分发这个，你可能想把它转换成后期绑定。

我们假设你的数据是正确的，就像你上面显示的那样。 换句话说，所有的标题都是偶数列。 结果在相邻的小区。

我们使用标题作为Key和词典项目的相邻单元格值创build词典。

• 我们收集信息
• 将键传送到VBA数组并按字母顺序sorting
• 创build一个“结果数组”并按顺序填充它
• 将结果写入工作表。

我将离开格式和标题生成给你。 顺便说一下，标题/值对列的数量在代码中是不变的。 我已经把它设置为3 ，但是你可以改变它。

请享用

---

 Option Explicit Option Compare Text 'If you want the sorting to be case INsensitive 'set reference to Microsoft Scripting Runtime Sub TidyData() 'Assume Titles are in even numbered columns 'Assume want ColPairs pairs of columns for output 'Use dictionary with Title as key, and Value as the item Dim dctTidy As Dictionary Dim arrKeys As Variant Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range Dim vSrc As Variant, vRes As Variant Dim LastRow As Long, LastCol As Long Dim I As Long, J As Long, K As Long, L As Long Dim V As Variant 'in Results Const ColPairs As Long = 3 'Set Source and results worksheet and range Set wsSrc = Worksheets("sheet1") Set wsRes = Worksheets("sheet2") Set rRes = wsRes.Cells(1, 2) 'Read source data into variant array With wsSrc.Cells LastRow = .Find(what:="*", after:=.Item(1, 1), _ LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row LastCol = .Find(what:="*", after:=.Item(1, 1), _ LookIn:=xlValues, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column vSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol)) End With 'Collect the data into a dictionary Set dctTidy = New Dictionary For I = 1 To UBound(vSrc, 1) For J = 2 To UBound(vSrc, 2) Step 2 If vSrc(I, J) <> "" Then _ dctTidy.Add Key:=vSrc(I, J), Item:=vSrc(I, J + 1) Next J Next I 'For this purpose, we can do a simple sort on the dictionary keys, ' and then create our results array in the sorted order. arrKeys = dctTidy.Keys Quick_Sort arrKeys, LBound(arrKeys), UBound(arrKeys) 'Create results array ReDim vRes(1 To WorksheetFunction.RoundUp(dctTidy.Count / ColPairs, 0), 1 To ColPairs * 2) I = 0 J = 0 For Each V In arrKeys K = Int(I / ColPairs) + 1 L = (J Mod ColPairs) * 2 + 1 vRes(K, L) = V vRes(K, L + 1) = dctTidy(V) I = I + 1 J = J + 1 Next V 'write the results Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2)) With rRes .Worksheet.Cells.Clear .Value = vRes .HorizontalAlignment = xlCenter End With End Sub Sub Quick_Sort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long) Dim Low As Long, High As Long Dim Temp As Variant, List_Separator As Variant Low = first High = last List_Separator = SortArray((first + last) / 2) Do Do While (SortArray(Low) < List_Separator) Low = Low + 1 Loop Do While (SortArray(High) > List_Separator) High = High - 1 Loop If (Low <= High) Then Temp = SortArray(Low) SortArray(Low) = SortArray(High) SortArray(High) = Temp Low = Low + 1 High = High - 1 End If Loop While (Low <= High) If (first < High) Then Quick_Sort SortArray, first, High If (Low < last) Then Quick_Sort SortArray, Low, last End Sub 

---

Answer 3

假设我们已经正确设置了所有的variables并进行了初始化，在这个例子中：

 Sheets("sheetname").Select ' because stupid things can happen... For i = 3 To 13 Let newrangeT = "B" & i ' Let newrangeV = "C" & i ' If Sheets("sheetname").Range(newrangeV) <> "" Then values(Position) = Sheets("sheetname").Range(newrangeV) titles(Position) = Sheets("sheetname").Range(newrangeT) Position = Position + 1 Else ' Don't do anything if the fields are null End If Next i Sheets("sheetname").Range("B1:G13").Clear 

'然后我们用For循环从数组中获取每个数据。 '我们设置一个columnsetvariables为1.'我们设置一个currentrowvariables为3.'如果columnset是1，数据将进入B和C，columnset = columnset +1'那么如果columnset是2，我们将数据设置为DE，columnset = columnset +1'但是，如果columnset是2，那么将数据设置为FG，columnset = 1，currentrow = currentrow +1'迭代数组将导致整齐的数据设置，但是会为所有的零增加零。 因此，我们需要一个If语句来排除那些检查TITLE数组（应该包含一个标题）的值。 如果值不是0，那么…我们运行我所描述的，否则我们什么也不做。

把数据放在数组中只有一半的技巧。

然后我们清除这个区域。

我们设置两个stringvariables来为循环中迭代的每个单元声明范围（实际上是单元格引用）。 在这里，我只对列B，C进行了演示，但是我们必须对列的其余部分执行相同的操作。 If语句在这里检查null。 你可能有不同的需求，所以改变if语句会改变过滤。 在这里，我检查单元格是否不为空。 如果C列的单元格包含数据，则将这些数据放在值数组中，并将相应的B数据放在标题数组中，但是在哪里？ 位置从1开始，然后我们每次迭代+1时迭代它。

您可以使用以下命令从数组中设置数据：

 ' current_row is set to the first row of the spreadsheet we wanna fill. Sheets("sheetname").Select ' because stupid things can happen... newrangeV = "C" & current_row Sheets("sheetname").Range(newrangeV) = values(j) 

剩下的就是把东西放在一起。

无论如何，我要感谢参与这个问题的两个人，因为我可能没有得到解决scheme，但是我知道如何去做其他的事情，比如意外地学习新东西。 干杯。