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