excel - 仅当标题为“名称”时，如何复制数据？

Question

我有大约 50 张工作簿，其中一些随机工作表中有员工姓名。我希望将所有名称复制到工作表 1 (A1)

请注意，数据不是表格格式。

我希望宏在所有工作表中运行并查找名称标题并将其粘贴到工作表 1 (A1) 中。

请注意“名称”列表可以在工作表中的任何位置，没有特定范围，因此宏需要找到“名称”单词并将整个列表复制到下一个空白行并将其粘贴到工作表 1 中再次找到“名称”单词并将其粘贴到可用列表下方的表 1。

Private Sub Search_n_Copy()
    Dim ws As Worksheet
       
    Dim rngCopy As Range, aCell As Range, bcell As Range
    Dim strSearch As String
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.CutCopyMode = False
  
    strSearch = "Name"
     
    For Each ws In Worksheets
    With ws
        Set rngCopy = Nothing
        Set aCell = .Columns(2).Find(What:=strSearch, LookIn:=xlValues, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        If Not aCell Is Nothing Then
            Set bcell = aCell

            If rngCopy Is Nothing Then
                Set rngCopy = .Rows((aCell.Row + 1) & ":" & (aCell.End(xlDown).Row))
            Else
                Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.End(xlDown).Row)))
            End If

            Do
                Set aCell = .Columns(2).FindNext(After:=aCell)

                If Not aCell Is Nothing Then
                    If aCell.Address = bcell.Address Then Exit Do

                    If rngCopy Is Nothing Then
                        Set rngCopy = .Rows((aCell.Row + 1) & (aCell.End(xlDown).Row))
                    Else
                        Set rngCopy = Union(rngCopy, .Rows((aCell.Row + 1) & ":" & (aCell.End(xlDown).Row)))
                    End If
                Else
                    Exit Do
                End If
            Loop
        
        End If

            '~~> I am pasting to sheet1. Change as applicable
        If Not rngCopy Is Nothing Then rngCopy.Copy Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Offset(1)
        Range("B2").Select
        Selection.End(xlDown).Select
        ActiveCell.Offset(0, -1).Range("A1").Select
        ActiveCell.FormulaR1C1 = "x"
        Range("A1").Select
    
    End With

标签： excelvba

Answer 1

您可以使用该Range.Find方法查找“名称”的所有实例。这样做的关键是跟踪你找到的第一个，这样当你Find回到那个单元格时，你就不会继续处理了。如果你不这样做，它将永远循环下去。这是一个例子。

Private Sub Search_n_Copy()

    Dim rFound As Range
    Dim sFirstFound As String

    'find the first instance of name
    Set rFound = Sheet1.UsedRange.Find("name", , xlValues, xlPart)

    'continue only if you found at least one instance
    If Not rFound Is Nothing Then
        'record the first one you found because Find loops back on itself
        sFirstFound = rFound.Address

        Do
            'copy the name to another sheet
            Sheet1.Range(rFound.Offset(1), rFound.Offset(1).End(xlDown)).Copy _
                Sheet2.Range("A1000").End(xlUp).Offset(1)

            'find the next instance of name
            Set rFound = Sheet1.UsedRange.FindNext(rFound)

        'stop looping when you get back to the first found cell
        Loop Until rFound.Address = sFirstFound
    End If

End Sub

如果你想为每张纸做这件事（可能不是你写结果的那张），它看起来像这样

Sub Search_n_Copy()

    Dim rFound As Range
    Dim sFirstFound As String
    Dim shSrc As Worksheet
    Dim shDest As Worksheet

    'Change this to match your sheet's name
    Set shDest = ThisWorkbook.Worksheets("Results")

    For Each shSrc In Worksheets
        If shSrc.Name <> shDest.Name Then
            With shSrc
                Set rFound = shSrc.UsedRange.Find("Name", , xlValues, xlPart)
                If Not rFound Is Nothing Then
                    sFirstFound = rFound.Address
                    Do
                        shSrc.Range(rFound.Offset(1), rFound.Offset(1).End(xlDown)).Copy _
                            shDest.Range("A1000").End(xlUp).Offset(1)
                        Set rFound = shSrc.UsedRange.FindNext(rFound)
                    Loop Until rFound.Address = sFirstFound
                End If
            End With
        End If
    Next shSrc

End Sub