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!

 

[mumps]

It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your destination sheet and one or two of your source sheets. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[nathanmav]

Hi mumps,

Thank you for your reply.

Sorry I don't know how to use XL2BB add-in. Explanation is in the excel mentioned what i need to copy and the condition.

Below link is the sample of my excel files.
Sample excel files

Screenshot of Destination workbook.

Thank you again.

 

[mumps]

I can't open the zipped file. Please upload an Excel file (unzipped).

 

[nathanmav]

Sorry mumps. Here is the link for the excel: Excel Files

Thank you

 

[mumps]

The columns containing "OVERDUE" and "FOR ACTION" in each of the source files are in different columns. Will they be in different columns in all the source files?

 

[nathanmav]

Yes it wil be different because some source files has less column and that column will be hidden in actual workbooks.
One more thing the source files are on our network server and the destination workbooks will be in my desktop.

Thank you

 

[mumps]

Place this macro in the destination workbook.

Sub Copydata()
    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
    Set odWS = ThisWorkbook.Sheets("OVERDUE")
    Set faWS = ThisWorkbook.Sheets("FOR ACTION")
    Const strPath As String = "C:\Users\User\Desktop\Report\" 'change the folder path to suit your needs
    ChDir strPath
    strExtension = Dir(strPath & "*.xlsx")
    Do While strExtension <> ""
        Set srcWB = Workbooks.Open(strPath & strExtension)
        With srcWB
            For Each ws In .Sheets
                If ws.AutoFilterMode Then ws.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(11).Find("OVERDUE")
                    Set fa = .Rows(11).Find("FOR ACTION")
                    .Cells(11, 1).CurrentRegion.AutoFilter od.Column, "OVERDUE"
                    Intersect(.Range("B12:J" & lRow3).SpecialCells(xlCellTypeVisible), .Range("B:C,E:E,J:J")).Copy odWS.Range("D" & lRow1)
                    .Range("A11").AutoFilter
                    .Cells(11, 1).CurrentRegion.AutoFilter fa.Column, "FOR ACTION"
                    Intersect(.Range("B12:J" & lRow3).SpecialCells(xlCellTypeVisible), .Range("B:C,E:E,J:J,L:M")).Copy faWS.Range("D" & lRow2)
                    .Range("A11").AutoFilter
                End With
            Next ws
            .Close savechanges:=False
        End With
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub

 

[nathanmav]

Hi mumps,

Thank you the code is working but there is some minor error see below image:

Is that possible in my actual workbook source excel files are password protected and can view in read only mode.
And also can I define which sheet that can be copied (ex. in source1 the macro only run in sheet1 to sheet4).

Thank you

 

[mumps]

Are the workbooks protected or are the sheets protected?