Excel VBA代码匹配多列中的值，然后将相应的值转置到单独的列

我的VBA技能充其量只是新手，我不知道如何有效地处理这一问题

目标：要匹配案例ID和客户端名称（一个案例ID可以有多个客户端），如果两者都匹配，则根据问题（问题列）从响应列中提取Q响应

我有两个源文件和一个目标文件。我已设法将所有必要的数据从源文件1（SF1）提取到目标文件（DF）

我需要从SF2中提取数据到DF

SF2数据的结构如下所示：

Case ID    Client Name   Question #   Response
10095      ABS            0.1          50
10095      ABS            0.2          100
10095      ABS            0.3          0
10095      ZZZ            0.1          0
10095      ZZZ            0.2          40
10095      ZZZ            0.3          99
29999      OVFLW          0.1          100

DF的结构/外观如下所示：

CASE ID   Client Name   0.1    0.2    0.3   
10095     ABS           50     100    0
10095     ZZZ           0      40     99
29999     OVFLW         100

我所拥有的代码能够获得上述所有内容，但无法解释额外变量，即除案例ID之外要匹配的客户名称。。欢迎提供任何想法/建议

先谢谢你。代码如下：

选项显式

Public Sub GrabKpiData3()

Dim sht As Worksheet, sht2 As Worksheet
Dim i As Long, k As Long
Dim lastrow As Long, lastcol, foundrow As Long, foundcol As Long

Dim macrobook As Workbook
Dim macrosheet As Worksheet

Set macrobook = ThisWorkbook
Set macrosheet = macrobook.Worksheets("Macro")

'source
Set sht = Workbooks("SourceFile2.csv").Worksheets("SF2")

'destination
Set sht2 = Workbooks("MacroFile.xlsm").Worksheets("Data")
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row

k = 2

For i = 2 To lastrow
    If sht2.Cells(k, 1).Value = sht.Cells(i, 1).Value Then
        'the below 2 rows grab different date values present within SF2. This would change based on match criteria requiring Case ID + Client name
        sht2.Cells(k, 16).Value = sht.Cells(i, 2).Value
        sht2.Cells(k, 17).Value = sht.Cells(i, 3).Value


        lastcol = sht2.Cells(1, sht2.Columns.Count).End(xlToLeft).Column

        'captures responses for 0.1
        sht2.Cells(k, 18).Value = sht.Cells(i, 6).Value

        i = i + 1

        'captures responses for 0.2
        sht2.Cells(k, 19).Value = sht.Cells(i, 6).Value

        i = i + 1

        'captures responses for 0.3
        sht2.Cells(k, 20).Value = sht.Cells(i, 6).Value

        i = i + 1

        sht2.Cells(k, 21).Value = sht.Cells(i, 6).Value

        i = i + 1

        sht2.Cells(k, 22).Value = sht.Cells(i, 6).Value

        k = k + 1

    Else

On Error Resume Next

    End If
Next i

End Sub

---

您可以使用SQL来完成数据的连接。我在你的数据之后镜像了我的数据，我调用了我的表SF2和DF以与你的示例相对应。添加对Microsoft Active X数据对象版本2.X的引用，以使其正常工作

Sub GetJoinedData()
    Dim conn        As ADODB.connection: Set conn = New ADODB.connection
    Dim rs          As ADODB.Recordset: Set rs = New ADODB.Recordset
    Dim outputsheet As Worksheet: Set outputsheet = ThisWorkbook.Sheets("Sheet1")
    Dim i           As Long: i = 1

    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
              ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES';"

    'My data is on two sheets named DF and SF2
    SQL = "Select [DF$].*, [SF2$].[Response] from [DF$] " & _
          "INNER JOIN [SF2$] on [SF2$].[Case ID] = [DF$].[Case ID] " & _
          "and [SF2$].[Client Name] = [DF$].[Client Name]"
    rs.Open SQL, conn, adOpenForwardOnly

    'Add headers
    For Each fld In rs.Fields
        outputsheet.Cells(1, i).Value = fld.Name
        i = i + 1
    Next

    'Dump the data
    outputsheet.Range("A2").CopyFromRecordset rs
End Sub

---

更新

我想我误解了你的第一个要求。我现在了解的是，您正在将结果放入

SF2

中，并将（一个轴心）转换为

DF

中的内容。我已经更新了代码来实现这一点

添加新问题时，它应该允许多个问题，并且在添加过程中保留列标题。希望能有帮助

Sub GetJoinedData()
    Dim conn        As ADODB.Connection: Set conn = New ADODB.Connection
    Dim rs          As ADODB.Recordset: Set rs = New ADODB.Recordset
    Dim outputsheet As Worksheet: Set outputsheet = ThisWorkbook.Sheets("DF")
    Dim i           As Long: i = 1

    conn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
              ThisWorkbook.FullName & ";Extended Properties='Excel 12.0;HDR=YES';"

    'My data is on two sheets named DF and SF2
    Sql = "TRANSFORM Max(response) " & _
          "SELECT [case id], [Client Name] " & _
          "FROM [SF2$] " & _
          "GROUP BY [case id], [Client Name] " & _
          "PIVOT [Question #];"

    rs.Open Sql, conn, adOpenForwardOnly

    'Add headers
    For Each fld In rs.Fields
        outputsheet.Cells(1, i).Value = Replace$(fld.Name, "_", ".") 'Fix a SQL formatting issue where _ exists
        i = i + 1
    Next

    'Dump the data
    outputsheet.Range("A2").CopyFromRecordset rs
End Sub

---

这是一个正常的VBA解决方案，应该可以工作（尽管SQL很好，但您可能会遇到一些兼容性/版本问题）

---

更新：已测试并修复了创建新标题的代码。

是否需要VBA？这可能通过公式实现。不幸的是，VBA是必要的：（涉及到其他数据+将来可能扩展到其他内容。看起来您不了解下一步错误恢复时的

工作原理。您可能应该删除它，并且只在绝对需要时使用它（这比您想象的要少）。对于
k
，您还需要一个完整的第二个for循环。整个
k=k+1
是不对的。@VBAWARD，您应该选择下面哪一个答案最有帮助。这样问题就不会一直悬而未决了。除了版本问题，如果您以后需要更改如何加入数据的逻辑，这会容易得多（也可以理解！）实现SQL以进行基于集合的比较。对于延迟的响应，我深表歉意。我一直在尝试处理此问题，并且它在大部分情况下都能正常工作。在尝试修改代码以适应我的情况时遇到的问题是需要添加新记录的部分。因为SF2仅根据案例ID已经存在于DF中，这部分代码似乎在DF的底部添加了一系列行，导致数据出现错误。关于如何解决这个问题，您有什么想法吗？@Profex:对于进一步的上下文，理想的做法是（用更简单的语言）DF宏检查SF2以查找匹配的案例ID和客户机名称，如果两者都找到，则返回对相应问题#的响应（这是DF中的标题，但它在SF2中检查的行的一部分）。我希望这是有意义的？@Profex:我已经修改如下。但是，它在底部创建了一行，我发现它的循环数据在此字段中，没有案例ID或客户端名称。知道我的代码有什么问题吗？编辑：抱歉，我无法将代码粘贴到此框中。如果有其他方法可以向您显示，请告诉我。@VBAWARD，在使用i…Next

循环处理任何其他数据之前，您可能需要添加一个检查，以确保CaseID/客户端名称不为空。除此之外，请确保在添加新行时递增

DestLastRow

。如果看不到您正在使用的更新代码和数据/文件，很难说是肯定的如果这两个文件是分开的，我可以修改吗？例如：我打开SourceFile2（SF2），然后打开DestinationFile（DF）并在DF上运行宏。是否需要定义从SourceFile2，sheet SF2中读取的路径或任何内容？要使其正常工作，所有数据都需要位于同一工作簿或文件中。是否有不合并数据的原因？可能需要将其全部拉入Excel中进行比较。或者，您可以将数据存储在类似于访问。经审查，这不会输出OP要求的内容。它有多条记录（行）对于相同的案例ID/客户机名称。此外，内部联接将表限制为两个表中的现有案例ID/客户机名称，并删除所有其他内容。在SQL中，这是一个更难解决的问题，特别是如果您希望动态添加列（即问题0.4）。这是一个很好的例子，说明了如何使用SQL从工作表中读取数据，但最终，它不起作用。尽管如此，我也需要修正我的答案。@Profex您将如何连接5个表？10？100？这是一个完整的洛塔循环。另一个解决方案不太适合附加范围。@RyanWildry，我只需调用该例程并将其传递给用户即可。@RyanWildryce和目标工作表；解决了范围/扩展问题。额外的循环没有什么大不了的（特别是与打开文件所需的时间相比）。它是最快的，不是；有一些改进，例如使用变体数组读取/写入数据，但这会使事情复杂化。我不认为速度是这里的主要问题。（仅供参考，如果源文件尚未在Excel中打开，则您的速度将提高10倍；如果源文件已在Excel中打开，则我的速度将提高10倍）

Set sht = Worksheets("SF2")
Set sht2 = Worksheets("DF")
SrcLastRow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row
DestLastRow = sht2.Cells(sht2.Rows.Count, 1).End(xlUp).Row
For i = 2 To SrcLastRow
    ' Find the row with a matching Case ID/Client Name
    For k = 2 To DestLastRow
        If sht2.Cells(k, 1).Value = sht.Cells(i, 1).Value And _
           sht2.Cells(k, 2).Value = sht.Cells(i, 2).Value Then _
            Exit For
    Next
    ' Updated - Forgot to add new records...
    If k > DestLastRow Then ' it's a new CaseID/Client Name, so add it
        sht2.Cells(k, 1).Value = sht.Cells(i, 1).Value
        sht2.Cells(k, 2).Value = sht.Cells(i, 2).Value
        DestLastRow = DestLastRow + 1
    End If

    q = 3 ' Starting column for Questions, look for a matching question/header (or blank)
    Do Until sht2.Cells(1, q).Value = sht.Cells(i, 3).Value Or sht2.Cells(1, q).Value = vbNullString
        q = q + 1
    Loop
    ' Write the header for the next question, if it doesn't exist
    If sht2.Cells(1, q).Value = vbNullString Then sht2.Cells(1, q).Value = sht.Cells(i, 3).Value

    ' Write the Response
    sht2.Cells(k, q).Value = sht.Cells(i, 4).Value
Next