Question

情况如何：

所以我得到了一个＆＃34;结果样本＆＃34;在excel格式，需要过滤和重塑看起来不错。这是一个不会始终如一的结果，但它遵循类似的规则。我必须进一步过滤它，使它更整洁。我已经找到了过滤部分，但我不确定如何以一种整洁的方式对剩余数据进行排序。

情况如何：

涉及六列。

注意：真正的交易不是那么简单，但我需要的东西可以用这么简单的例子来证明，然后我可以自己管理更复杂的东西。

对于我们的示例，我们使用从B到G的列数据被设置为＆＃34;标题＆＃34;和一个价值。例如，如果您查看我提供的第一个示例图片，则第一个显示对B3和C3。

正如你所看到的，看着同一张照片，D3和E3是一对空的。 D4-E4和F4-G4也是如此，直到B11-C11的最后一个为止。启动数据示例：

[ Scattered data]

我想要实现的目标：

我想，使用Visual Basic for Applications，对数据进行排序，从我们的示例B3（参见第二张图片）开始，填写三列两列，（BC，DE，FG）如果这些单元格内没有数据。

注意：如果像D3这样的单元格为空，那么SURELY E3也将为空，因此只能进行一次检查。我的意思是我们可以检查值列或标题列。

注意事项2：必须对B，D，F或C，E，G列DON'进行排序。我只想要B，D，F的所有非空值以及它们各自的值从C，E，G聚集在一起整齐，所以打印不需要30页但只需要几个（两者之间的空间太大导致它和我尝试自动清理）

Answer 1

Here's something to start with. The first double loop populates a VBA Collection with Range variables that refer to the Cells that contain the titles. The associated values are obtained by using an offset. The middle double loop performs a bubble sort on the latter (highly inefficient - you might want to replace it with something else). The next if statement creates a 2nd sheet if it doesn't exist on which to write out the results (last loop).

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 Scripting Runtime的引用。如果您要分发此内容，您可能希望将其转换为后期绑定。

我们假设您的数据在上面显示时已正确形成。换句话说，所有标题都在偶数列中;结果在相邻的细胞中。

我们使用Title作为Key创建字典，并使用Dictionary项的相邻单元格值。

我们收集信息
将密钥传输到VBA阵列并按字母顺序排序
创建一个＆＃34;结果数组＆＃34;并按顺序填充
将结果写入工作表。

我会将格式和标题生成留给您。顺便说一下，代码中有一个常量标题/值对列的数量。我已将其设置为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

假设我们正确设置并初始化了所有变量，在本例中：

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循环从数组中获取每个数据。 '我们将columnset变量设置为1。 '我们将currentrow变量设置为3。 '如果列集为1，则数据将输入B和C，列集=列集+1 '然后，如果columnset为2，我们将数据设置为DE，columnset = columnset +1 '但是如果列集是2，我们将数据设置为FG，列集= 1，则currentrow = currentrow +1 '迭代数组将导致数据整齐设置，但它会为所有空值添加零。因此，我们需要一个If语句来排除检查TITLE数组的值（应该包含标题）。如果值不是0那么......我们运行我描述的内容，否则我们什么都不做。

将数据放入数组只是技巧的一半。

然后我们清除该区域。

我们设置两个字符串变量来为循环中迭代的每个单元声明范围（实际上是单元格引用）。这里我只演示了列集B，C 但是我们必须对其余的列做同样的事情。这里的If语句检查null。您可能有不同的需求，因此更改if语句会更改过滤。在这里，我检查单元格是否为空。如果列C的单元格包含数据，请将这些数据放在values数组中，将相应的B数据放在titles数组中，但是在哪里？位置从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)

剩下的就是把事情放在一起。

无论如何，我要感谢参与这个问题的两个人，因为我可能没有得到解决方案，但我知道如何做其他事情，比如不小心学习新东西。欢呼声。

使用VBA在Excel中收集数据整洁

3 个答案: