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

Question

我的 VBA 技能充其量只是新手，我不知道如何有效地解决这个问题。

目标：匹配案例 ID # 的 AND 客户端名称（一个案例 ID # 可以有多个客户端），如果它们都匹配，则拉 Q基于问题#（问题列）的响应列的响应

我有 2 个源文件和一个目标文件。我已经设法将所有必要的数据从源文件 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

我拥有的代码能够获得上述所有内容，但无法说明额外变量是客户端名称，以匹配 到 CASE 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

Answer 1

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

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

更新：经过测试和修复的代码可创建新标头。

Answer 2

您可以使用 SQL 来完成这种数据连接。我已经按照你的数据镜像了我的数据，我称我的工作表 SF2 和 DF 与你的示例相对应。添加对Microsoft Active X Data Object version 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