Question

我一直试图将其拼凑在一起，但到目前为止仍未成功。

工作表2（工作表名称为“ Sheet1”）具有需要拖入工作表（工作表名称为“ DATA”）的数据。

工作簿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

我想做的是获取代码以问题＃遍历该列（在“ Sheet1”工作簿2中），并且学生编号是否匹配，以及工作簿2中的问题编号是否与该列匹配标题，然后返回学生编号，完成日期以及最重要的是匹配列标题下的得分值。

我一直在尝试使用的代码如下。任何建议都将受到欢迎：

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

VBA代码可将单元格值与列标题匹配，并在循环中返回单元格值

1 个答案: