Home » excel » excel – VBA Code to match values in multiple columns and then transpose corresponding values to separate columns

excel – VBA Code to match values in multiple columns and then transpose corresponding values to separate columns

Posted by: admin May 14, 2020 Leave a comment

Questions:

My VBA skills are novice at best and I’m unaware as to how to approach this efficiently.

Goal: To match Case ID #’s AND the Client Name (One case ID # can have multiple clients) and if they both match, then pull the Q response from the Response column based on the Question # (Question column)

I have 2 source files and one destination file. I have managed to extract all necessary data from source file 1(SF1) to the destination File (DF).

I need to pull out data from SF2 to the DF.

The SF2 Data is structured as follows:

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

The DF is structured/would look like as the following:

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

The code I have is able get all of the above, but cannot account for the extra variable being the Client Name to match against in addition to the CASE ID. Any ideas/suggestions would be welcome.

Thank you in advance. Code below:

Option Explicit

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
How to&Answers:

Here is a normal VBA solution which should work (although the SQL is nice, you may run into some compatibility/version issues)…

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

Update: Tested and fixed code to create new headers.

Answer:

You can use SQL to accomplish this joining of data. I’ve mirrored my data after yours, I called my sheets SF2 and DF to correspond with your examples. Add a reference to Microsoft Active X Data Object version 2.x for this to work correctly.

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

Update

I think I misunderstood your first ask. What I now understand is you are taking the results in SF2 and transforming (a Pivot) to what is in DF. I’ve updated my code to do that.

It should multiple allow for new questions when they are added, and you retain the column headers along the way. Hope it helps.

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