Question

我有一个包含多个工作表的文档，我需要使用inputtring搜索A列以查找与它们匹配的所有值，并将它们复制到MergedData工作表。它需要从搜索中排除“SUB PAYMENT FORM”，“Details”和“MergeData”。它需要从第16行开始搜索每个工作表，直到最后一行。

在合并数据表中，我需要在Cell A1开始复制数据，然后是A2，依此类推...

我想当按钮被点击并复制数据时我希望有一个消息框显示，说明已从中复制数据的工作表名称，我还希望它显示工作表名称的位置没有数据被发现。

下面是我目前的代码，它会搜索所有相关表格并将数据复制到MergedData表格。但它没有给我说明数据发现位置的消息框。

它还将数据粘贴到MergedData表中，从第2行开始，而不是第1行。

非常感谢您提供的任何帮助。

由于 Aarron

Sub SearchForString() 
Dim FirstAddress As String,  
WhatFor A String 
Dim Cell As Range, Sheet As Worksheet     

With Application    
    .ScreenUpdating = False         
    .EnableEvents = False        
    .CutCopyMode = False     
End With   

WhatFor = InputBox("What are you looking for?", "Search Criteria")
Worksheets("MergedData").Cells.Clear

If WhatFor = Empty Then Exit Sub 
For Each Sheet In Sheets
If Sheet.Name <> "SUB PAYMENT" And Sheet.Name <> "MergedData" And Sheet.Name <> "Details" Then

With Sheet.Columns(1) Set Cell = .Find(   WhatFor, LookIn:=xlValues, LookAt:=xlWhole)

If Not Cell Is Nothing Then 
FirstAddress = Cell.Address 
Do
Cell.EntireRow.Copy Destination:=Sheets("MergedData").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If 
End With 
End If
Next Sheet Set Cell = Nothing
End Sub

Answer 1

养成适当增加代码的习惯，以提高可读性。

这应该可以正常运作：

Sub SearchForString()

Dim FirstAddress As String, _
    WhatFor As String, _
    Cell As Range, _
    Sheet As Worksheet, _
    MatchIn As String, _
    NotMatch As String

With Application
    .ScreenUpdating = False
    .EnableEvents = False
    .CutCopyMode = False
End With

WhatFor = InputBox("What are you looking for?", "Search Criteria")
Worksheets("MergedData").Cells.Clear

If IsEmpty(WhatFor) Then Exit Sub

For Each Sheet In Sheets
    If Sheet.Name <> "SUB PAYMENT" And Sheet.Name <> "MergedData" And Sheet.Name <> "Details" Then
        With Sheet.Columns(1)
            Set Cell = .Find(What:=WhatFor, _
                            After:=.Cells(16, 1), _
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                            SearchOrder:=xlByColumns, _
                            SearchDirection:=xlNext, _
                            MatchCase:=False, _
                            SearchFormat:=False)
            If Not Cell Is Nothing Then
                FirstAddress = Cell.Address
                'MsgBox Cell.Parent.Name
                If InStr(1, MatchIn, Cell.Parent.Name) <> 0 Then
                    'already noted sheet
                Else
                    MatchIn = MatchIn & Cell.Parent.Name & Chr(13)
                End If
                Do
                    Cell.EntireRow.Copy Destination:=Sheets("MergedData").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                    Set Cell = .FindNext(Cell)
                Loop Until Cell Is Nothing Or Cell.Address = FirstAddress Or Cell.Row < 16
            End If
        End With
    End If
Next Sheet

Set Cell = Nothing
Worksheets("MergedData").Rows(1).EntireRow.Delete

For Each Sheet In Sheets
    If Sheet.Name <> "SUB PAYMENT" And _
            Sheet.Name <> "MergedData" And _
            Sheet.Name <> "Details" And _
            InStr(1, MatchIn, Sheet.Name) = 0 Then
        NotMatch = NotMatch & Sheet.Name & Chr(13)
    End If
Next Sheet

With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .CutCopyMode = True
End With


MsgBox WhatFor & " found in :" & Chr(13) & MatchIn & _
        Chr(13) & "Not found in :" & Chr(13) & NotMatch

End Sub

根据条件将多个工作表中的数据复制到1

1 个答案: