Функция Excel: извлечение данных с использованием диапазона поиска с несколькими и разнородными данными

Я пытаюсь создать отчет, в котором столбец, содержащий несколько уникальных данных, используется в качестве идентификаторов при извлечении данных из исходной таблицы / базы данных, где массив поиска содержит ячейки или поля, которые содержат несколько разнородных и повторяющихся данных.

Приведенная ниже иллюстрация может объяснить, что я пытаюсь сделать:

Это исходная таблица

И нижеприведенный отчет - это то, чего я пытаюсь достичь:

Я пытаюсь найти похожие вопросы, но безрезультатно. Я могу классифицировать себя как промежуточного пользователя в Excel, особенно на стороне VBA.

У меня было немного свободного времени, поэтому я написал макрос VBA, который может автоматизировать это. Поскольку у вас есть некоторые знания о VBA, изучите этот код и поймите, где когда-либо существует жесткое кодирование. Макрос делает три вещи

1. Транспонировать данные из входной таблицы в выходную таблицу.
2. Сортировать таблицу вывода
3. Объедините повторяющиеся ячейки значений в первом столбце. Однако я предлагаю вам прокомментировать эту часть кода, чтобы в будущем применение сводной таблицы к выходной таблице было упрощено при необходимости.

В этом примере таблица ввода представлена ​​в формате A1: C4 (A2: A4 - это ячейки с именем продукта). Выходная таблица начинается с ячейки E1. Поместите это жесткое кодирование в VBA, чтобы соответствовать диапазонам таблицы. Лист будет назван как «Лист1». В коде жестко задано имя листа, диапазон входных ячеек и выходная начальная ячейка. Пожалуйста, посмотрите все экземпляры кода для правильной работы.

На листе нажмите ALT + F11, чтобы открыть редактор VBA, вставить модуль и вставить в него приведенный ниже код, чтобы создать макрос с именем Report.

Sub Report()
Dim noofrows As Integer
Dim startrow As Integer
Dim startcol As Integer
Dim repstartrow As Integer
Dim repstartcol As Integer
Dim bincode As String
Dim storagecode As String
'Hard Coding below
noofrows = Range("A2:A4").Rows.Count  'Specify the Input Data Range from a Column
startrow = Range("A2").Row
startcol = Range("A2").Column
repstartrow = Range("E1").Row         'Specify Output Data Table's First Cell here
repstartcol = Range("E1").Column

Cells(repstartrow, repstartcol).Value = "Products"
Cells(repstartrow, repstartcol).Font.Bold = True
Cells(repstartrow, repstartcol + 1).Value = "BinCode"
Cells(repstartrow, repstartcol + 1).Font.Bold = True
Cells(repstartrow, repstartcol + 2).Value = "StorageCode"
Cells(repstartrow, repstartcol + 2).Font.Bold = True

repstartrow = repstartrow + 1

For i = 1 To noofrows

   Dim strTest As String
   Dim strArray() As String
   Dim intCount As Integer

   strTest = Cells(startrow, startcol).Value
   strArray = Split(strTest, ";")
   bincode = Cells(startrow, startcol + 1).Value
   storagecode = Cells(startrow, startcol + 2).Value


   For intCount = LBound(strArray) To UBound(strArray)
      Cells(repstartrow, repstartcol).Value = strArray(intCount)
      Cells(repstartrow, repstartcol + 1).Value = bincode
      Cells(repstartrow, repstartcol + 2).Value = storagecode
      repstartrow = repstartrow + 1
   Next intCount
   startrow = startrow + 1

Next i

'Create All Borders to the table
'Hard Coding below
repstartrow1 = Range("E1").Row
repstartcol = Range("E1").Column

repstartrow = repstartrow - 1

Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Select
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlThin
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideVertical)
        .LineStyle = xlContinuous
    End With
    With Selection.Borders(xlInsideHorizontal)
        .LineStyle = xlContinuous
    End With

'Auto Fit the Columns
Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Columns.AutoFit

'Sort the range on Product then Bincode & then StorageCode

Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2)).Select
    ActiveSheet.Sort.SortFields.Clear
    ActiveSheet.Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol), Cells(repstartrow, repstartcol)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol + 1), Cells(repstartrow, repstartcol + 1)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range(Cells(repeatstartrow + 1, repstartcol + 2), Cells(repstartrow, repstartcol + 2)), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveSheet.Sort
        .SetRange Range(Cells(repstartrow1, repstartcol), Cells(repstartrow, repstartcol + 2))
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With


'Optional - Merge Cells with repeating Values. Simply comment below code if not desired
repstartrow1 = Range("E1").Row + 1
repstartcol = Range("E1").Column

Application.DisplayAlerts = False
For i = repstartrow1 To repstartrow - 1
        For j = i + 1 To repstartrow
            If Cells(i, repstartcol).Value <> Cells(j, repstartcol).Value Then
                Exit For
            End If
        Next
        Range(Cells(i, repstartcol), Cells(j - 1, repstartcol)).Merge
        Range(Cells(i, repstartcol), Cells(j - 1, repstartcol)).VerticalAlignment = xlTop
        i = j - 1
    Next
Range(Cells(repstartrow1 - 1, repstartcol), Cells(repstartrow1 - 1, repstartcol)).Select

Application.DisplayAlerts = True

End Sub

Сохраните и вернитесь на рабочий лист. Нажмите клавиши ALT + F8, чтобы открыть диалоговое окно «Макрос», и запустите макрос с именем «Отчет», чтобы получить нужную таблицу вывода. Обратите внимание, что вы не должны повторно запускать этот макрос снова и снова. Это будет работать только один раз. Однако вы можете очистить предыдущую выходную таблицу и повторно запустить этот макрос, чтобы воссоздать выходную таблицу с нуля. Макрос может быть дополнительно улучшен, чтобы очистить предыдущую таблицу в качестве первого шага, прежде чем продолжить.