VBA to copy certain columns from multiple workbooks with multiple worksheet based on criteria into master workbook

[nathanmav]

Hi everyone,

I would like to ask for help about the code I found and I tried to modify it but I'm not lucky to make it work.
I have a total of eight (8) workbooks with more than one (1) worksheets. What I'm trying to achieved is copy a certain column if the condition is met.

Here is the code:

Sub copydata()
   
    Dim lastrow As Integer
    Dim i As Integer As Integer
    Dim erow As Integer
    Dim xlsDestination As Workbook  'Master Workbook
    Dim xlsSource As Workbook       'Source Workbook
    Dim xlsDestSheet As Worksheet   'Destination Sheet
    Dim xlsSourceSheet As Worksheet 'Source Sheet
    Dim RefNo, Rev, Desc, DateSub

    Application.ScreenUpdating = False
       
    Set xlsDestination = ThisWorkbook
    Set xlsDestSheet = xlsDestination.Sheets("Master")
   
    Set xlsSource = Workbooks.Open("C:\Users\User\Desktop\Report\Source1.xlsx") 'I have lots of source workbooks
    Set xlsSourceSheet = xlsSource.Sheets("Sheet1") 'The problem here is source file composed of more than 1 sheet in every workbooks
   
    lastrow = xlsDestSheet.Range("A" & Rows.Count).End(xlUp).Row

    For i = 12 To lastrow 'starting row to copy in Source File
        If xlsSourceSheet.Cells(i, 13).Value = "C" And xlsSourceSheet.Cells(i, 17).Value = "LT" Then ' This the condition if condition is met
            'change the column numbers to the relevant number (from Source Workbook)
            RefNo = xlsSourceSheet.Cells(i, 2).Value
            Rev = xlsSourceSheet.Cells(i, 3).Value
            Desc = xlsSourceSheet.Cells(i, 5).Value
            DateSub = xlsSourceSheet.Cells(i, 10).Value

            erow = xlsDestSheet.Cells(xlsDestSheet.Rows.Count, 1).End(xlUp).Offset(1, 0).Row

            'change the column numbers to the relevant number (to Master Workbook)
            xlsDestSheet.Cells(erow, 4).Value = RefNo
            xlsDestSheet.Cells(erow, 5).Value = Rev
            xlsDestSheet.Cells(erow, 6).Value = Desc
            xlsDestSheet.Cells(erow, 7).Value = DateSub
        End If
    Next i
Application.ScreenUpdating = True

End Sub

Thank you in advance!

 

[nathanmav]

Also this additional row (12) I will change the font color and background to white so that it will not visible.

 

[mumps]

Try changing

.Cells(11, 1)

to

.Cells(12, 1)

 

[nathanmav]

Try changing

.Cells(11, 1)

to

.Cells(12, 1)

I tried to change all to 12 but still showing error check image below.

Thank you

 

[mumps]

Please upload a copy of your file.

 

[nathanmav]

Here is the copy of my file.
Excel File

Thank you

 

[mumps]

What is the password for the Material workbook?

 

[nathanmav]

What is the password for the Material workbook?

Sorry I forgot to give it to you..
password: 1234

 

[mumps]

Start by deleting all the formulas in the OVERDUE and FOR ACTION sheets. Try this macro.

Sub TestCOPY()
    Application.ScreenUpdating = False
    Dim lRow1 As Long, lRow2 As Long, lRow3 As Long
    Dim odWS As Worksheet, faWS As Worksheet, srcWB As Workbook, ws As Worksheet, od As Range, fa As Range
    Dim no As Range, desc As Range, rev As Range, SD As Range, RD As Range, Stat As Range, shArr As Variant, i As Long
    Set odWS = ThisWorkbook.Sheets("OVERDUE")
    Set faWS = ThisWorkbook.Sheets("FOR ACTION")
    Const strPath As String = "F:\Testing Report\New folder\" 'change the folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        If strExtension = "1. Material.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension, ReadOnly:=True)
            shArr = Array("CV", "ST", "AR", "EL", "ME")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    If ws.Range("A12").AutoFilter Then AutoFilterMode = False
                    lRow1 = odWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    lRow2 = faWS.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                    With ws
                        lRow3 = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
                        Set od = .Rows(12).Find("OVERDUE")
                        Set fa = .Rows(12).Find("FOR ACTION")
                        With .Rows(12)
                            Set no = .Find("Ref No")
                            Set desc = .Find("Desc")
                            Set rev = .Find("Rev")
                            Set SD = .Find("Sub Date")
                            Set RD = .Find("Rep Date")
                            Set Stat = .Find("Stat")
                        End With
                        .Range("A12").AutoFilter od.Column, Criteria1:="OVERDUE"
                        Intersect(.Range("B13:R" & lRow3).SpecialCells(xlCellTypeVisible), Union(.Columns(no.Column), .Columns(rev.Column), .Columns(desc.Column), .Columns(SD.Column)).EntireColumn).Copy odWS.Range("D" & lRow1)
                        .Range("A12").AutoFilter
                        .Range("A12").AutoFilter fa.Column, "FOR ACTION"
                        Intersect(.Range("B13:R" & lRow3).SpecialCells(xlCellTypeVisible), Union(.Columns(no.Column), .Columns(rev.Column), .Columns(desc.Column), .Columns(SD.Column), .Columns(RD.Column), .Columns(Stat.Column)).EntireColumn).Copy faWS.Range("D" & lRow2)
                        .Range("A12").AutoFilter
                    End With
                Next i
                .Close savechanges:=False
            End With
        End If
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[nathanmav]

Hi mumps,

There are some extra rows generated by the macro in OVERDUE sheet. And in FOR ACTION the REP DATE is missing.

Thank you.

 

[nathanmav]

Hi mumps,

It works I just remove all the .CurrentRegion and add Criteria1:= beside OVERDUE and FOR ACTION and its running like a charm although its a little bit slow because I have lots of workbooks and rows. But its fine anyway how can I use this .PasteSpecial Paste:=xlPasteValues because some rows has a hyperlink to a PDF files.

Thank you very much for your help.