Excel VBA筛选和分组行vba

Question

首先，感谢您的答案。我正在使用Excel工作表和vba，并且遇到问题。

我有这样的数据（表1）：

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

而且我想如下（表2），以创建一个结构化的信息一个新的工作表：

REFERENCE ORIGIN DISTRIBUTED 
2014.AOK  Iran Bulgaria, Spain 

正如你所看到的在表1中，参考对于3行是相同的。每一行都有不同的国家。我的目标是将所有信息写入1行，具体取决于“DISTRIBUTED”。

• 如果一个国家在DISTRIBUTED列中有1，那么应该在最后一个在该列中有1的地方添加。在这个例子中，保加利亚和西班牙应该在同一列中，用逗号隔开。

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

非常感谢你非常非常！

Answer 1

如果这是一个一次性的锻炼; Tibial然后我会用公式中的工作表，将是最快的创造，但如果需要可重复使用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列中。你可以改变它，以便原始数据被输出数据取代，但那取决于你。

Answer 2

这应该工作。
它不，但它应该。虽然可以帮助别人。

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