基于单元值将特定行复制到另一个工作簿

Question

我想将行（A：E），行（F：AH）和行（AL）从活动工作簿复制到行（A：E），行（G：AI），另一个工作簿的行（AJ）。这是我正在处理的代码。我在这里看到它，然后编辑它。

Dim wb1 As Workbook, wb2 As Workbook 
Dim ws1 As Worksheet, ws2 As Worksheet 
Dim copyFrom As Range 
Dim lRow As Long 
Dim strSearch As String 
Dim ret 

ret = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls, .xlsx*),*.xls, .xlsx*", _ 
            Title:="Select data file for Monitoring Log") 
Set wb1 = ThisWorkbook 
Set ws1 = wb1.Worksheets("Macro Template") 

strSearch = "Newly Distributed" 

With ws1 

    .AutoFilterMode = False 

    lRow = .Range("AL" & .Rows.Count).End(xlUp).Row 

    With .Range("AL7:AL" & lRow) 
     .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*" 
     Set copyFrom = .Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow 
    End With 

    '~~> Remove any filters 
    .AutoFilterMode = False 
End With 

'~~> Destination File 
Set wb2 = Application.Workbooks.Open(ret) 
Set ws2 = wb2.Worksheets("Source") 

With ws2 
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 
     lRow = .Cells.Find(What:="*", _ 
         After:=.Range("A1"), _ 
         Lookat:=xlPart, _ 
         LookIn:=xlFormulas, _ 
         SearchOrder:=xlByRows, _ 
         SearchDirection:=xlPrevious, _ 
         MatchCase:=False).Row + 1 
    Else 
     lRow = 1 
    End If 

    copyFrom.Copy .Rows(lRow) 
End With 

wb2.Save 
wb2.Close 

此代码复制整个行。我如何修改它以复制特定的行。

Answer 1

更换

copyFrom.Copy .Rows(lRow) 

与

copyFrom.Columns("A:E").Copy .Cells(lRow, "A") 
copyFrom.Columns("F:AH").Copy .Cells(lRow, "G") 
copyFrom.Columns("AL").Copy .Cells(lRow, "AJ") 

Answer 2

从源代码，我只是可以看到你从列AL复制到另一个工作表的数据。
我修改了你的代码，并成功复制到另一个工作表中。复制功能可以写成1行而不是多行。

Option Explicit 
Dim wb1 As Workbook 
Dim wb2 As Workbook 
Dim ws1 As Worksheet 
Dim ws2 As Worksheet 
Dim lRow As Long 
Dim lRow2 As Long 
Dim strSearch As String 

Sub Test() 

Dim ret 

ret = Application.GetOpenFilename(FileFilter:="Excel Workbooks (*.xls, .xlsx*),*.xls, .xlsx*", _ 
            Title:="Select data file for Monitoring Log") 
Set wb1 = ThisWorkbook 
Set ws1 = wb1.Worksheets("Macro Template") 

strSearch = "Newly Distributed" 

With ws1 

    .AutoFilterMode = False 

    lRow = .Cells(Rows.Count, "AL").End(xlUp).Row 
    'lRow = .Range("AL" & .Rows.Count).End(xlUp).Row 

    With .Range("AL7:AL" & lRow) 
     .AutoFilter Field:=1, Criteria1:="=*" & strSearch & "*" 
    End With 

End With 

'~~> Destination File 
Set wb2 = Application.Workbooks.Open(ret) 
Set ws2 = wb2.Worksheets("Source") 

With ws2 
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then 
     lRow2 = .Cells(Rows.Count, "A").End(xlUp).Row 
    Else 
     lRow2 = 1 
    End If 

    'copyFrom.Copy .Rows(lRow) 
    ws1.Range("AL8:AL" & lRow).SpecialCells(xlCellTypeVisible).Copy Destination:=ws2.Range("A" & lRow2) 
End With 

    '~~> Remove any filters 
    ws1.AutoFilterMode = False 

wb2.Save 
wb2.Close 
End Sub