使用所有匹配的string运行外部工作簿并复制粘贴到另一个工作簿

嗨，目前我有一个代码，允许我通过一个名为“活动主项目”外部工作簿，并search“新加坡”组成的列，它不止一次出现在列中。 我需要一个能够帮助我遍历所有行的代码，并将A列中包含“Singapore”的所有信息复制到另一个名为“easy project tracker”的工作簿中。 我现在所用的代码似乎不起作用，因为它只复制粘贴第一个“新加坡”，并将停止在整个行中运行，以search在A列中具有“新加坡”的其余行。

Sub Sample() Dim wb1 As Workbook, wb2 As Workbook Dim ws1 As Worksheet, ws2 As Worksheet Dim copyFrom As Range Dim lRow As Long '<~~ Not Integer. Might give you error in higher versions of excel Dim strSearch As String Set wb1 = Application.Workbooks.Open("U:\Active Master Project .xlsm") Set ws1 = wb1.Worksheets("New Upcoming Projects") strSearch = "Singapore" With ws1 '~~> Remove any filters .AutoFilterMode = False '~~> I am assuming that the names are in Col A '~~> if not then change A below to whatever column letter lRow = .Range("A" & .Rows.Count).End(xlUp).row With .Range("A4:A" & lRow) .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*" Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow End With .AutoFilterMode = False End With '~~> Destination File Set wb2 = ThisWorkbook Set ws2 = wb2.Worksheets("New Upcoming Projects") With ws2 If Application.WorksheetFunction.CountA(.Cells) <> 0 Then lRow = .Cells.Find(What:="*", _ After:=.Range("A4"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).row Else lRow = 1 End If copyFrom.Copy .Rows(lRow) End With End Sub 

以上是我现在的代码，但似乎没有工作，因为我想要的。 任何帮助将非常感激。 谢谢。 🙂

Answer 1

我更喜欢自动筛选路线为您的问题。 基于A列中“新加坡”标准的自动筛选结果将暂时转移到同一工作簿中的临时表中。 从工作表结果转移到新的工作簿。 然后清除Temp表格的内容。 macros文件是一个单独的工作簿。 我附加下面的代码。 也可以从下面提到的链接下载示例文件。

http://1drv.ms/1J8a3pv Active_Master_Project.xlsx

http://1drv.ms/1J8amR9 Easy_Project_Tracker.xlsx

http://1drv.ms/1J8av72 Macro_File.xlsm

 Sub Test2() Set x = Workbooks.Open("c:\mydir\Active_Master_Project.xlsx") 'Change dir path Set y = Workbooks.Open("c:\mydir\Easy_Project_Tracker.xlsx") Set ws3 = y.Sheets("New_Upcoming_Projects") Set ws1 = x.Sheets("New_Upcoming_Projects") Set ws2 = x.Sheets("Temp") Dim LastRow As Long ws2.UsedRange.Offset(0).ClearContents With ws1 .Range("$A:$A").AutoFilter field:=1, Criteria1:="Singapore" LastRow = .Range("A" & .Rows.Count).End(xlUp).Row .Range("A1:A" & LastRow).SpecialCells(xlCellTypeVisible).EntireRow.Copy _ Destination:=ws2.Range("A1") End With ws1.AutoFilterMode = False ActiveWorkbook.Save With ws2 .Cells.Copy ws3.Cells .UsedRange.Offset(0).ClearContents End With x.Close y.Close End Sub