人们进行一项调查，他们的回答最终会出现在 Excel 电子表格中的一行中。人们进行多项调查，因此他们的回答分布在多个工作表中。这些人在每次调查之前都有使用的 ID。
我想循环遍历每个工作表中的行，并从包含特定人员的调查响应的行中复制某些单元格。假设将回复放入电子表格的人知道 ID。
Sub CreateSPSSFeed()
Dim StudentID As String ' (StudentID is a unique identifier)
Dim Tool As Worksheet ' (this is the worksheet I'm pulling data into)
Dim Survey1 As Worksheet ' (this is the sheet I'm pulling data from)
Dim i As Integer ' (loop counter)
Tool = ActiveWorkbook.Sheets("ToolSheet")
Survey1 = ActiveWorkbook.Sheets("Survey1Sheet")
' (This is how the loop knows what to look for)
StudentID = Worksheet("ToolSheet").Range("A2").Value
ActiveWorksheet("Survey1").Select ' (This loop start with the Survey1 sheet)
For i = 1 to Rows.Count ' (Got an overflow error here)
If Cells (i, 1).Value = StudentID Then
'!Unsure what to do here-- need the rest of the row
' with the matching StudentID copied and pasted
' to a specific row in ToolSheet, let's say starting at G7!
End If
Next i
End Sub
我在这里进行了研究，但将循环与跨页移动结合起来并没有太多运气。
这个不好，但可能会让你继续：
Sub CreateSPSSFeed()
Dim StudentID As String '(StudentID is a unique identifier)
Dim Tool As Worksheet '(this is the worksheet I'm pulling data into)
Dim Survey1 As Worksheet '(this is the sheet I'm pulling data from)
'Dim i As Integer '(loop counter) 'You don't need to define it
Set Tool = ActiveWorkbook.Worksheets("ToolSheet") 'you'll need to use the Set command, don't ask why
Set Survey1 = ActiveWorkbook.Worksheets("Survey1Sheet")
ToolLastRow = Tool.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'so you won't need to loop through a million rows each time
Survey1LastRow = Survey1.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Survey1LastColumn = Survey1.Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
For j = 2 To ToolLastRow 'For each student ID from A2 down on toolsheet
StudentID = Tool.Cells(j, 1).Value2 '(This is how the loop knows what to look for) 'why define it if you don't use it
'ActiveWorksheet("Survey1").Select '(This loop start with the Survey1 sheet) 'Activeworksheet -> Activeworkbook but unnecessary,see below
For i = 1 To Survey1LastRow '(Got an overflow error here) 'you won't get an overflow error anymore
If Cells(i, 1).Value2 = StudentID Then
'!Unsure what to do here--need the rest of the row with the matching StudentID copied and pasted to a specific row in ToolSheet, let's say starting at G7!
'let's put the data starting at survey1's B# to the cells starting at tool's G#
For k = 2 To Survey1LastColumn '2 refers to B, note the difference between B=2 and G=7 is 5
Tool.Cells(j, k + 5) = Survey1.Cells(i, k)
Next k
End If
Next i
Next j
End Sub
这将检查工作簿中以“调查”开头的所有工作表中的第 1:500 行（可以轻松更改为整列或不同范围），并粘贴到工具表。 确保工具表上的学生 ID 之间有足够的空间来粘贴所有可能出现的情况。
FIND方法来自这里：https://msdn.microsoft.com/en-us/library/office/ff839746.aspx
Sub CreateSPSSFeed()
Dim sStudentID As String
Dim shtTool As Worksheet
Dim rFoundCell As Range
Dim sFirstFound As String
Dim rPlacementCell As Range
Dim lCountInToolSheet As Long
Dim wrkSht As Worksheet
'Set references.
With ActiveWorkbook
Set shtTool = .Worksheets("ToolSheet")
sStudentID = .Worksheets("ToolSheet").Cells(2, 1).Value
End With
'Find where the required student id is in the tool sheet.
With shtTool.Range("A:A")
'Will start looking after second row (as this contains the number you're looking for).
Set rPlacementCell = .Find(sStudentID, After:=.Cells(3), LookIn:=xlValues, LookAt:=xlWhole, SearchDirection:=xlNext)
'If the Student ID doesn't appear in column A it
'will find it in cell A2 which we don't want.
If rPlacementCell.Address = .Cells(2).Address Then
'Find the last row on the sheet containing data -
'two rows below this will be the first occurence of our new Student ID.
lCountInToolSheet = .Find("*", After:=.Cells(1), SearchDirection:=xlPrevious).Row + 2
'An existing instance of the number was found, so count how many times it appears (-1 for the instance in A2)
Else
lCountInToolSheet = WorksheetFunction.CountIf(shtTool.Range("A:A"), sStudentID) - 1
End If
'This is where our data will be placed.
Set rPlacementCell = rPlacementCell.Offset(lCountInToolSheet)
End With
'Look at each sheet in the workbook.
For Each wrkSht In ActiveWorkbook.Worksheets
'Only process if the sheet name starts with 'Survey'
If Left(wrkSht.Name, 6) = "Survey" Then
'Find each occurrence of student ID in the survey sheet and paste to the next available row
'in the Tool sheet.
With wrkSht.Range("A1:A500")
Set rFoundCell = .Find(sStudentID, LookIn:=xlValues, LookAt:=xlWhole)
If Not rFoundCell Is Nothing Then
sFirstFound = rFoundCell.Address
Do
'Copy the whole row - this could be updated to look for the last column containing data.
rFoundCell.EntireRow.Copy Destination:=rPlacementCell
Set rPlacementCell = rPlacementCell.Offset(1)
Set rFoundCell = .FindNext(rFoundCell)
Loop While Not rFoundCell Is Nothing And rFoundCell.Address <> sFirstFound
End If
End With
Set rFoundCell = Nothing
End If
Next wrkSht
End Sub
编辑：我添加了更多注释和额外代码，因为我意识到第一部分始终会找到放置在单元格 A2 中的学生 ID。
试试这个：
Sub CreateSPSSFeed()
Dim StudentID As String '(StudentID is a unique identifier)
Dim rng as Range
StudentID = Worksheet("ToolSheet").Range("A2").Value 'if you get error try to add Set = StudentID.....
j = 7
for x = 2 to sheets.count
For i = 1 to Sheets(x).Cells(Rows.Count, 1).End(xlUp).Row 'last not empty row
If sheets(x).Cells (i, 1).Value = StudentID Then
sheets(x).range(cells(i, 2),cells(i, 6)).copy _'adapt range to your needs
Destination:=activesheet.Cells(j, 7) 'this is G7
j = j + 1
End If
Next i
next x
End Sub
仅从将数据汇集到“工具”的工作表中运行此代码。 现在，您已经在工作表循环中嵌套了行循环。 PS：无需复制整行，只需按值范围即可，以避免错误。