Excel 函数：使用查找范围提取多个异构数据

Question

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

下图可以解释我想要完成的任务：

这是源表

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

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

Answer 1

我有一些空闲时间，所以我写了一个可以自动执行此操作的 VBA 宏。既然您对 VBA 有所了解，请仔细阅读此代码并了解哪里存在一点硬编码。宏执行三件事

1. 将输入表中的数据转置到输出表中。
2. 对输出表进行排序
3. 合并第一列中的重复值单元格。不过我建议您注释掉这部分代码，这样以后在需要时将数据透视表应用到输出表时就会变得简单。

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

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