遍历工作表，查找特定值，将具有匹配值的行粘贴到另一张工作表

Question

人们参加了一项调查，他们的回答最终在 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

我在这里进行了研究，但在将循环与跨表移动相结合时运气不佳。

Answer 1

这个不好，但可能会让你继续前进：

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

Answer 2

这将检查工作簿中以“调查”开头的所有工作表中的第 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

编辑：我已经添加了更多的 cmets 和额外的代码，因为我意识到第一部分总是会找到放置在单元格 A2 中的学生 ID。

Answer 3

试试这个：

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：不需要复制整行，只要有值的范围，避免错误。