Vba 如何从行中搜索、查找和选择数据并复制到新工作表

我需要构建一个宏来查找表1中所需的行，该行由a列中的值预先确定，然后将同一行中特定列的值（

D:F）复制到表2上的预定位置

不幸的是，我不能让宏总是引用相同的单元格，因为数据不会总是从1A开始，它可能从第3行或第10行或任何地方开始。列应该每次都保持在相同的位置，但我肯定需要宏来搜索列a中所需的内容

另外，我不想复制整行，因为第1页后面的列中有更多数据，这与第2页中我需要的数据完全无关

下面是我需要做的一个例子来更好地解释：

第1页（原始数据）

表2（预期结果）

这里有一段代码可以帮助您

Sub SetGrade()

Dim srcSheet As Worksheet
Dim trgtSheet As Worksheet
Dim foundVal As Object
Dim i

Set srcSheet = ThisWorkbook.Sheets(1)
Set trgtSheet = Workbooks("book2").Sheets(1)

For i = 1 To trgtSheet.Cells(trgtSheet.Rows.Count, "A").End(xlUp).Row 'iterate through column A in target sheet

    Set foundVal = srcSheet.Columns(1).Find(srcSheet.Range("a" & i).Value) 'take value from column a target sheet then look for it in column A sourcesheet

    srcSheet.Range(foundVal.Offset(0, 3), foundVal.Offset(0, 5)).Copy Destination:=trgtSheet.Range("B" & i) ' take cells columns D:F from found row and paste them into range starting at column B and row from which search criteria was taken

Next i

End Sub

您需要根据您的情况调整工作簿名称等
我不知道如何使建议的公式搜索到我需要的内容，因此我只是使用了该公式，然后删除了它提取的额外列。这不是最奇特或最有效的方法，但却完成了任务

 Sub DesperateTimes()
    Dim Cell As Range
    For i = 25 To 100
    Sheets("sheet1").Select
    If Cells(i, "A").Value = "Title" Then
    Rows(i).Select
    Selection.Copy
    Sheets("sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    End If
    Sheets("sheet1").Select
    If Cells(i, "A").Value = "2A" Then
    Rows(i).Select
    Selection.Copy
    Sheets("sheet2").Select
    Range("A2").Select
    ActiveSheet.Paste
    End If
    Sheets("sheet1").Select
    If Cells(i, "A").Value = "4A" Then
    Rows(i).Select
    Selection.Copy
    Sheets("sheet2").Select
    Range("A3").Select
    ActiveSheet.Paste
    End If
    Sheets("sheet1").Select
    If Cells(i, "A").Value = "3A" Then
    Rows(i).Select
    Selection.Copy
    Sheets("sheet2").Select
    Range("A4").Select
    ActiveSheet.Paste
    End If
    Sheets("sheet2").Select
    Columns("E:EZ").Select
    Selection.ClearContents

    Next i

    End Sub

到目前为止，您有什么代码？不幸的是，由于我不知道如何编写，没有一个代码与我的要求相关。到目前为止，我所拥有的只是我需要的新工作表的创建和格式设置。我已经将您的代码放入我的工作表中，但不确定如何获得所需的结果。我不太确定代码是否能做到这一点（我对excel宏非常熟悉，但我看不到代码在哪里根据列A的内容查找正确的行。基本上，我需要它在列A中搜索一个值（比如在1:250的范围内），一旦找到值，就选择两列以上的单元格（根据示例），将它们粘贴到所需位置，然后重复我需要的下一行。我已对工作簿名称进行了更改，但仍然看不到宏在何处搜索我要查找的内容。我需要以下代码的等效代码（用于其他用途）但要搜索行中的值而不是列中的值，并且不复制整行，只需选择.Dim单元格上的几列值作为i=1到200页的范围（“下载”）。选择If Cells（2，i）.Value=“Symbol”然后是第（i）列。选择选择。复制工作表（“缩小”）。选择范围（“A1”）。选择活动工作表。在代码中粘贴结束IFADED注释，应该可以消除您的疑虑
Sub SetGrade()

Dim srcSheet As Worksheet
Dim trgtSheet As Worksheet
Dim foundVal As Object
Dim i

Set srcSheet = ThisWorkbook.Sheets(1)
Set trgtSheet = Workbooks("book2").Sheets(1)

For i = 1 To trgtSheet.Cells(trgtSheet.Rows.Count, "A").End(xlUp).Row 'iterate through column A in target sheet

    Set foundVal = srcSheet.Columns(1).Find(srcSheet.Range("a" & i).Value) 'take value from column a target sheet then look for it in column A sourcesheet

    srcSheet.Range(foundVal.Offset(0, 3), foundVal.Offset(0, 5)).Copy Destination:=trgtSheet.Range("B" & i) ' take cells columns D:F from found row and paste them into range starting at column B and row from which search criteria was taken

Next i

End Sub

 Sub DesperateTimes()
    Dim Cell As Range
    For i = 25 To 100
    Sheets("sheet1").Select
    If Cells(i, "A").Value = "Title" Then
    Rows(i).Select
    Selection.Copy
    Sheets("sheet2").Select
    Range("A1").Select
    ActiveSheet.Paste
    End If
    Sheets("sheet1").Select
    If Cells(i, "A").Value = "2A" Then
    Rows(i).Select
    Selection.Copy
    Sheets("sheet2").Select
    Range("A2").Select
    ActiveSheet.Paste
    End If
    Sheets("sheet1").Select
    If Cells(i, "A").Value = "4A" Then
    Rows(i).Select
    Selection.Copy
    Sheets("sheet2").Select
    Range("A3").Select
    ActiveSheet.Paste
    End If
    Sheets("sheet1").Select
    If Cells(i, "A").Value = "3A" Then
    Rows(i).Select
    Selection.Copy
    Sheets("sheet2").Select
    Range("A4").Select
    ActiveSheet.Paste
    End If
    Sheets("sheet2").Select
    Columns("E:EZ").Select
    Selection.ClearContents

    Next i

    End Sub