Код VBA для сопоставления значения ячейки с заголовком столбца и возврата значения ячейки в цикле

Question

Я пытался собрать это воедино, но пока безуспешно.

Workbook2 с именем листа «Sheet1» содержит данные, которые необходимо перенести в Workbook1, с именем листа «DATA».

Workbook 2:

Student ID    Date completed   Question#  Score
101            12/10/2018        1         0
101            12/10/2018        2         5
101            12/10/2018        3         10
101            12/10/2018        4         0
102            12/05/2018        1         10
102            12/05/2018        2         0

Рабочая тетрадь 1:

Student ID  Date Completed  Question1  2   3   4
101         12/10/2018       0         5   10  0
102         12/05/2018       10        0

То, что я пытаюсь сделать, - это получить код для циклического прохождения по столбцу с вопросом № (в «Листе 1», тетрадь 2), а также, если номера учеников совпадают, и еслиномер вопроса в Рабочей тетради 2 совпадает с заголовком столбца в Листе «ДАННЫЕ» (Рабочая тетрадь 1), затем возвращает номер студента, дату завершения и, самое главное, значение оценки под соответствующим заголовком столбца.

Код I 'Я пытался использовать ниже.Любые предложения приветствуются:

Public Sub grabqdata()


Dim wbmacro As Workbook
Dim wblean As Workbook

Set wbmacro = Workbooks.Item("MacroFile.xlsm")
Set wblean = Workbooks.Item("Workbook2.xlsx")

Dim wsmacro As Worksheet
Dim wslean As Worksheet

Set wsmacro = wbmacro.Worksheets.Item("Data")
Set wslean = wblean.Worksheets.Item("Sheet1")

Dim leanrange As Range
Set leanrange = wslean.Range("A2:A150000")

Dim headerrange As Range
Set headerrange = wsmacro.Range("A1:G1")

Dim qrange As Range
Set qrange = wslean.Range("D2:D150000")

Dim macrorange As Range
Set macrorange = wsmacro.Range("A:A")

Dim lastrow As Long

lastrow = Cells(Rows.Count, "A").End(xlUp).Row

Dim colm As Long
colm = WorksheetFunction.Match(wsmacro, Range("A1:G1"), 0)


Dim cell As Range


i = 1


For Each cell In leanrange

    If leanrange.Range("A2") = macrorange.Range("a2") Then


        wsmacro.Range("C2").Offset(i, 0) = wslean.Range("D2").Offset(i, 0)


        i = i + 1
    End If

Next cell

End Sub

В столбце C находится первый Q # (поэтому Q1 или «1»).

Спасибо!

Answer 1

Не самый красивый, но это должно сделать работу ... Это также делает некоторые предположения, например, что не существует нескольких завершенных дат для одного и того же студенческого идентификатора (требуется пояснение) - также предполагается, что каждый студент проходит один и тот жевопрос № (1, 2, 3 и т. д.).

Option Explicit
Sub Test()

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

Set sht = Workbooks("Testfile1.xlsm").Worksheets("Sheet1")
Set sht2 = Workbooks("Testfile2.xlsm").Worksheets("Sheet1")
lastrow = sht.Cells(sht.Rows.Count, 1).End(xlUp).Row

sht2.Cells.ClearContents
sht2.Cells(1, 1).Value = "Student ID"
sht2.Cells(1, 2).Value = "Date completed"
sht2.Cells(1, 3).Value = "Question # 1"
k = 2

For i = 2 To lastrow
    If Application.CountIf(sht2.Range("A:A"), sht.Cells(i, 1).Value) = 0 Then
        sht2.Cells(k, 1).Value = sht.Cells(i, 1).Value
        sht2.Cells(k, 2).Value = sht.Cells(i, 2).Value

        lastcol = sht2.Cells(1, sht2.Columns.Count).End(xlToLeft).Column

        sht2.Cells(k, 3).Value = sht.Cells(i, 4).Value
        k = k + 1
    Else
        foundrow = sht2.Range("A:A").Find(What:=sht.Cells(i, 1).Value).Row

        On Error Resume Next
        foundcol = sht2.Range("1:1").Find(What:="Question # " & sht.Cells(i, 3).Value).Column
        On Error GoTo 0

        If foundcol = 0 Then
            lastcol = sht2.Cells(1, sht2.Columns.Count).End(xlToLeft).Column
            sht2.Cells(1, lastcol + 1).Value = "Question # " & sht.Cells(i, 3).Value
            sht2.Cells(foundrow, lastcol + 1).Value = sht.Cells(i, 4).Value
        Else
            sht2.Cells(foundrow, foundcol).Value = sht.Cells(i, 4).Value
        End If
    End If
Next i

End Sub