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 строку, в зависимости от «РАСПРОСТРАНЕННЫЙ».

• Если страна имеет 1 в РАСПРОСТРАНЕННОЙ колонке, ее следует добавить после последней, которая имела 1 в этой колонке. В этом примере Болгария и Испания должны быть вместе в той же колонке, разделенной запятой.

Я попытался сделать это с помощью vba, но я понятия не имею, как это сделать. Не могли бы вы дать мне ключ?

спасибо очень очень !!

Answer 1

Если это один от Excercise, то я хотел бы использовать формулу в таблицу, как это было бы быстрым, чтобы создать, однако, если вам нужно повторно используемый код 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