Код VBA для сопоставления значений в нескольких столбцах, а затем транспонирования соответствующих значений в отдельные столбцы - PullRequest
Новая
       14

Код VBA для сопоставления значений в нескольких столбцах, а затем транспонирования соответствующих значений в отдельные столбцы

0 голосов
/ 03 января 2019

Мои навыки VBA в лучшем случае новички, и я не знаю, как подойти к этому эффективно.

Цель : для сопоставления идентификатора случая # * И имени клиента (один идентификатор случая может иметь несколько клиентов) и, если они оба совпадают, затем потяните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.Любые идеи / предложения будут приветствоваться.

Спасибо заранее.Код ниже:

Вариант Явный 

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

Ответы [ 2 ]

0 голосов
/ 03 января 2019

Вот нормальное решение 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

Обновление: проверенный и исправленный код для создания новогозаголовки.

0 голосов
/ 03 января 2019

Вы можете использовать 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 и трансформируете (Pivot) в то, что находится в 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
...