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

Question

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

目标 :要匹配案例 ID #'s AND the Client Name(一个案例 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

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

更新:经过测试和修复的代码可以创建新的 header 。