Excel VBA 过滤和分组行 vba

Question

首先，提前感谢您的回答。我正在使用 Excel worksheets 和 vba，但我遇到了问题。

我有这个数据（TABLE 1）：

REFERENCE     COUNTRIES   ORIGIN   DISTRIBUTED
2014.AOK      Iran          1          0
2014.AOK      Bulgaria      0          1
2014.AOK      Spain         0          1

我想创建一个新的 sheet，其信息结构如下 (TABLE 2):

REFERENCE    ORIGIN   DISTRIBUTED
2014.AOK      Iran    Bulgaria, Spain

正如您在 table 1 中所见，3 行的引用相同。每行都有不同的国家。我的目标是根据 "DISTRIBUTED".

将所有信息写在 1 行中

如果一个国家/地区在 DISTRIBUTED 列中有 1，则应将其添加到该列中最后一个有 1 的国家之后。在这个例子中，保加利亚和西班牙应该在同一列中，用逗号分隔。

我已经尝试使用 vba 来做到这一点，但我不知道该怎么做。你能给我一个线索吗？

非常非常非常感谢！！

Answer 1

这应该有效。
它没有，但它应该。不过可能会帮助其他人。

Sub ert()
e = NamesArrayFiltered(Range("B:B"), Range("D:D"), 1, Range("A:A"), "2014.AOK")
MsgBox e
End Sub

'

Public Function NamesArrayFiltered(myNames As Range, Optional Filter1 As Range, Optional FilterCriterion1 As Variant, _
                                   Optional Filter2 As Range, Optional FilterCriterion2 As Variant) As String
NamesArrayFiltered = ""
Dim FilterFound(1 To 2) As Boolean
    FilterFound(1) = Not Filter1 Is Nothing
        If FilterFound(1) Then FilterFound(1) = Not Filter1 Is Nothing
    FilterFound(2) = Not Filter2 Is Nothing
        If FilterFound(2) Then FilterFound(2) = Not Filter2 Is Nothing
Set Filter1 = Intersect(Filter1, Filter1.Worksheet.UsedRange)
Set myNames = Intersect(myNames, myNames.Worksheet.UsedRange)
Set Filter2 = Intersect(Filter1, Filter1.Worksheet.UsedRange)

Dim RowsCount As Long, ColumnsCount As Long, CellsCount As Long
RowsCount = Filter1.Rows.Count
ColumnsCount = Filter1.Columns.Count
CellsCount = Filter1.Cells.Count
Dim NamesArray() As Variant, Counter1 As Long
ReDim NamesArray(1 To CellsCount)
Counter1 = 1

On Error Resume Next
For i = 1 To RowsCount
    For j = 1 To ColumnsCount
        If FilterFound(1) Then
            If Filter1(i, j).Value2 = FilterCriterion1 Then
                If FilterFound(2) Then
                    If Filter2(i, j).Value2 = FilterCriterion2 Then
                        NamesArray(Counter1) = myNames(i, j).Value2
                        Counter1 = Counter1 + 1
                    End If
                Else
                    NamesArray(Counter1) = myNames(i, j).Value2
                    Counter1 = Counter1 + 1
                End If
            End If
        End If
            'If (Filter1(i, j).Value2 = FilterCriterion1 And FilterFound(1)) And (Filter1(i, j).Value2 = FilterCriterion1 And FilterFound(1)) Then
            '    NamesArray(Counter1) = myNames(i, j).Value2
            '    Counter1 = Counter1 + 1
            'End If
    Next j
Next i
NamesArrayFiltered = Join(NamesArray(), ", ")
NamesArrayFiltered = Left(NamesArrayFiltered, InStr(NamesArrayFiltered, ", , ") - 1)
End Function

Answer 2

如果这是一次性练习，那么我会在工作表中使用公式，因为这样创建起来最快，但是如果您需要可重复使用的 VBA 代码，那么我会使用数组中的数据，像这样：

Dim i As Long, k As Long
Dim avArray As Variant
Dim rngOriginal As Range, rngExpanded As Range

'get the range of the original table of data
Set rngOriginal = ThisWorkbook.Worksheets(1).Range("A1").CurrentRegion

'increase the range by the number of output columns we require, 3 in this case, then dump into array
Set rngExpanded = Range(rngOriginal.Resize(rngOriginal.Rows.Count, rngOriginal.Columns.Count + 3).Address)
avArray = rngExpanded.Value

'loop though the rows ignoring the first row (headers)
For i = (LBound(avArray, 1) + 1) To UBound(avArray, 1)
    If avArray(i, 3) = 1 Then 'if origin then
        k = i 'remember row
        avArray(i, 5) = avArray(i, 1) 'output reference
        avArray(i, 6) = avArray(i, 2) 'output origin country
    End If
    If avArray(i, 4) = 1 Then 'if distributed then
        If avArray(k, 7) = vbNullString Then 'if first distributed
            avArray(k, 7) = avArray(i, 2) 'then just assign country
        Else
            avArray(k, 7) = Join(Array(avArray(k, 7), avArray(i, 2)), ",") 'else join to existing countries
        End If
    End If
Next

'dump array back to sheet
rngExpanded.Value = avArray

此特定解决方案要求首先对数据进行适当排序，即按引用排序，然后按来源排序，然后按分发排序。

此代码会将输出数据放在原始数据旁边的 3 列中。您可以更改它，以便将原始数据替换为输出数据，但这取决于您。

Excel VBA 过滤和分组行 vba

Excel VBA filtering and grouping rows vba

excel

grouping

vba

rows