Copy from closed workbook to open with a keyword problem

[CaliburBlade138]

Hey all,

I wrote some code to open up an excel file and get the number of used rows, but I am stumped on figuring out looking for a keyword *WH* in column J, if found, copy row and paste in new workbook, can anyone help finish this code?

Sub Import_Data_And_Update()

Dim workbookA As Workbook, worksheetA As Worksheet
Dim workbookB As Workbook, worksheetB As Worksheet
Dim myFileName As String
Dim myLastR As Long

'Open the file dialog picker
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        If .Show = False Then Exit Sub
        myFileName = .SelectedItems.Item(1)
    End With

'This workbook
Set workbookA = ThisWorkbook
Set worksheetA = workbookA.Sheets("Status")

Application.ScreenUpdating = False

'The workbook we are going to open
Set workbookB = Workbooks.Open(myFileName, True, True)
Set worksheetB = workbookB.Sheets("Backlog")

myLastR = worksheetB.Cells(Rows.Count, 1).End(xlUp).Row

'Do code here to copy from and to...



workbookB.Close False

End Sub

 

[dmt32]

Hi,
see if this update to your code will help you

Sub Import_Data_And_Update()
   
    Dim workbookA   As Workbook, workbookB As Workbook
    Dim worksheetA  As Worksheet, worksheetB As Worksheet
    Dim myFileName  As String
    Dim copyrng     As Range
   
    'Open the file dialog picker
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = False
        .Filters.Add "Excel Files", "*.xlsx; *.xlsm; *.xls; *.xlsb", 1
        If .Show = False Then Exit Sub
        myFileName = .SelectedItems.Item(1)
    End With
   
    On Error GoTo myerror
    'This workbook
    Set workbookA = ThisWorkbook
    Set worksheetA = workbookA.Worksheets("Status")
   
    Application.ScreenUpdating = False
   
    'The workbook we are going to open
    Set workbookB = Workbooks.Open(myFileName, True, True)
    Set worksheetB = workbookB.Worksheets("Backlog")
   
    With worksheetB
        With .Cells(1, 1).CurrentRegion
            .AutoFilter Field:=10, Criteria1:="=*WH*"
        End With
        Set copyrng = .AutoFilter.Range
    End With
   
    'Do code here to copy from and to...
   
    If copyrng.Rows.Count > 1 Then
       
        copyrng.SpecialCells(xlCellTypeVisible).Copy worksheetA.Range("A1")
       
    Else
   
        Err.Raise 600, , "No Matches Found"
       
    End If
   
myerror:
    If Not workbookB Is Nothing Then workbookB.Close False
    Application.ScreenUpdating = True
    If Err <> 0 Then MsgBox (Error(Err)), 48, "Error"
   
End Sub

Solution untested & you will need to adapt code as required to meet specific project need

Dave

 

[CaliburBlade138]

Thank you!

 

[dmt32]

Thank you!

welcome & appreciate feedback

Dave

 

[CaliburBlade138]

Works as expected.