Question

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

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

我希望Macro在所有工作表中运行，并查找Name标头并将其粘贴到工作表1（A1）中。

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

私人子Search_n_Copy（）作为工作表昏暗

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"

对于工作表中的每个ws 与ws 设置rngCopy = Nothing 设置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

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

仅当标题为“名称”时才需要复制数据

1 个答案: