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!
 

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
117
Here are the list that I need to copy:

1596810249930.png


Thank you
 

Some videos you may like

Excel Facts

How to calculate loan payments in Excel?
Use the PMT function: =PMT(5%/12,60,-25000) is for a $25,000 loan, 5% annual interest, 60 month loan.

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
The headers on all the sheets are not the same. Sorry. Perhaps someone else can help you. :(
 

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
117
The headers on all the sheets are not the same. Sorry. Perhaps someone else can help you. :(
I can make it all the same header name that is for sample only.
Here is what I will do. Is this possible?
1596812797987.png


Thank you
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
Ref No., Doc No. and Trans No. are not the same but since they all contain "No." that should be enough. Please upload 2 or 3 revised source files with the new headers.
 

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
117

ADVERTISEMENT

Ref No., Doc No. and Trans No. are not the same but since they all contain "No." that should be enough. Please upload 2 or 3 revised source files with the new headers.
I can adjust it all Ref No also.
Check the excel file I adjust it all with same header name in all source files.
Excel Files

Thank you
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
Try:
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
    Dim no As Range, desc As Range, rev As Range, SD As Range, RD As Range, Stat 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")
                    With .Rows(11)
                        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("Status")
                    End With
                    .Cells(11, 1).CurrentRegion.AutoFilter od.Column, "OVERDUE"
                    Intersect(.Range("B12:R" & lRow3).SpecialCells(xlCellTypeVisible), Union(.Columns(no.Column), .Columns(rev.Column), .Columns(desc.Column), .Columns(SD.Column)).EntireColumn).Copy odWS.Range("D" & lRow1)
                    .Range("A11").AutoFilter
                    .Cells(11, 1).CurrentRegion.AutoFilter fa.Column, "FOR ACTION"
                    Intersect(.Range("B12: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("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

ADVERTISEMENT

Mumps this amazing its working.. is that possible that you can add a clear contents meaning for example after few days I will run again the macro it should clear the old data.

Thank you very much.. this is really a big help and will save lot of time.
 
Last edited:

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,588
Insert these two lines of code:
VBA Code:
odWS.UsedRange.Offset(11).ClearContents
faWS.UsedRange.Offset(11).ClearContents
immediately below this line:
VBA Code:
Set faWS = ThisWorkbook.Sheets("FOR ACTION")
 

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
117
Insert these two lines of code:
VBA Code:
odWS.UsedRange.Offset(11).ClearContents
faWS.UsedRange.Offset(11).ClearContents
immediately below this line:
VBA Code:
Set faWS = ThisWorkbook.Sheets("FOR ACTION")

Thank you very much mumps.

One more thing where can I add the code that can access read only file.
I try put in this part is that correct?
VBA Code:
Set srcWB = Workbooks.Open(strPath & strExtension, ReadOnly:=True)

Also I add this part after the
VBA Code:
Set faWS = ThisWorkbook.Sheets("FOR ACTION")
VBA Code:
    odWS.Range("D12:G100").EntireRow.Delete
    faWS.Range("D12:I100").EntireRow.Delete

I cant use this code in my original file there are some formula in OVERDUE (A to C, H to I), FOR ACTION (A to C, J) and if I clear it all the formula will be clear also.
"Insert these two lines of code:
VBA Code:
odWS.UsedRange.Offset(11).ClearContents
faWS.UsedRange.Offset(11).ClearContents"





Thank you again.
 
Last edited:

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
117
But this code I add is not working error showing "Delete method of Range class failed"
VBA Code:
   odWS.Range("D12:G100").EntireRow.Delete
    faWS.Range("D12:I100").EntireRow.Delete
 

Watch MrExcel Video

Forum statistics

Threads
1,109,179
Messages
5,527,270
Members
409,756
Latest member
punknwilly

This Week's Hot Topics

Top