根据条件将多张数据复制到1

我有一个有多个工作表的文档，我需要使用一个inputstring来search列A，以查找匹配它们的所有值，然后将它们复制到合并数据表中。 它需要从search中排除“子付款表格”，“详细信息”和“合并数据”。 它需要search每行从第16行开始直到最后一行。

在合并的数据表中，我需要数据开始复制在单元格A1，然后是A2等等…

我想当button被点击和数据复制，我想有一个消息框显示，说明数据被复制的工作表名称，我也希望它显示没有数据find的工作表名称。

下面是我现在的代码，它search所有相关的表单并将数据复制到MergedData表单中。 但是它并没有给我显示数据被发现的消息框。

它还将数据粘贴到第2行而不是第1行的MergedData表中。

任何帮助，您可以提供将不胜感激。

谢谢阿隆

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