Question

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

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

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

您可以使用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

Answer 2

这是一个正常的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

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

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

2 个答案: