Excel功能：使用具有多个异构数据的查找范围来提取数据

我正在尝试生成一个报告，其中包含多个唯一数据的列用作从源表/数据库中提取数据的标识符，其中查找数组包含具有多个，异构和重复数据的单元格或字段。

下面的插图可以解释我想要实现的目标：

这是源表

以下报告是我想要完成的：

我试图找到类似的问题但无济于事。我可以将自己归类为Excel中的中级用户，尤其是在VBA方面。

我有一些业余时间，所以我写了一个可以自动化的VBA宏。由于您对VBA有一定的了解，因此请通过此代码了解哪里存在少量硬编码。宏做了三件事

1. 将输入表中的数据转换为输出表。
2. 对输出表进行排序
3. 合并第一列中的重复值单元格。但是，我建议您对代码的这一部分进行注释，以便将来在应用数据透视表时将其简化为输出表。

在此示例中，输入表位于A1：C4（A2：A4是产品名称单元格）。输出表从单元格E1开始。将此硬编码放在VBA中以匹配您的表范围。该表被命名为“Sheet1”。代码中的Sheet名称和输入单元格范围以及输出起始单元格有硬编码。请查看所有实例以使代码正常工作。

在工作表中按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以访问宏对话框并运行名为Report的宏以获取所需的输出表。 请注意，您不应该反复重新运行此宏。它只会工作一次。但是，您可以清除以前的输出表并再次重新运行此宏以从头开始重新创建输出表。在继续之前，可以进一步增强宏以清除前一个表作为第一步。