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

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
117
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:
VBA 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!
 

Some videos you may like

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
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

Board Regular
Joined
Dec 11, 2012
Messages
117
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.
sample.JPG


Thank you again.
 
Last edited:

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
I can't open the zipped file. Please upload an Excel file (unzipped).
 

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
117

ADVERTISEMENT

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

Thank you
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
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

Board Regular
Joined
Dec 11, 2012
Messages
117

ADVERTISEMENT

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

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
Place this macro in the destination workbook.
VBA Code:
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

Board Regular
Joined
Dec 11, 2012
Messages
117
Hi mumps,

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

error1.JPG


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

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
Are the workbooks protected or are the sheets protected?
 

Watch MrExcel Video

Forum statistics

Threads
1,109,176
Messages
5,527,251
Members
409,754
Latest member
ekTZ

This Week's Hot Topics

Top