Question

嗨，目前我有一个代码，可以让我查看名为“Active master project”的外部工作簿，并搜索包含“Singapore”的列，并且它在列中不止一次出现。我需要一个代码来帮助我遍历所有行，并将A列中包含“Singapore”的所有信息复制到另一个名为“easy project tracker”的工作簿中。我现在的代码似乎不起作用，因为它只复制粘贴第一个“新加坡”，并将停止遍历整行以搜索在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

我首选您的问题自动过滤路线。自动过滤结果基于标准＆＃34;新加坡＆＃34;在A列中临时传输到同一工作簿中的Temp Sheet。从临时表结果转移到新工作簿。之后清除临时表的内容。宏文件是一个单独的工作簿。我附上下面的代码。您也可以从下面提到的链接下载示例文件。

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

使用所有匹配的字符串运行外部工作簿并将其复制粘贴到另一个工作簿

1 个答案: