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

N

nathanmav

Board Regular
Joined
Dec 11, 2012
Messages
123
Office Version
  1. 2019
  2. 2016
Platform
  1. Windows
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!
 
Sort by date Sort by votes
You are very welcome. :)
I believe that is correct. However, I'm not sure if the macro will work on a read only file.
 
Upvote 0

Excel Facts

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
mumps said:
You are very welcome. :)
I believe that is correct. However, I'm not sure if the macro will work on a read only file.
Click to expand...
Its working but the problem is the code that I add showing error of "Delete method of Range class failed"

VBA Code: 
    Set faWS = ThisWorkbook.Sheets("FOR ACTION")
    odWS.Range("D12:G100").EntireRow.Delete
    faWS.Range("D12:I100").EntireRow.Delete
 
Upvote 0
As I mentioned, the macro may not work if the workbook is read only.
 
Upvote 0
mumps said:
As I mentioned, the macro may not work if the workbook is read only.
Click to expand...
Hi mumps,

I tried in my original source workbooks I would like to ask how can I exclude some sheets when running the loop macro.

Original source workbooks
- source1(CV,ST,AR,EL,ME,REP,SUM)
REP & SUM will be exclude

- source2(CV,ST,AR,EL,ME,OTH,REP,SUM)
SUM will be excluded

-source3(TR,CV,ST,AR,EL,ME,MEP,GEN,SKT,SUM,REP)
CV,ST,AR,EL,ME,MEP,GEN,SKT,SUM,REP will be excluded

Is there a way to specify which sheet in source workbooks that need to be copied.

Thank you
 
Upvote 0
How many source workbooks are there? Will this number ever change? In order to do what you want, the source workbook names must be similar. What are the actual full names of the source files including extension?
 
Upvote 0
I have a total of 8 workbooks and all password protected.

1596890450262.png


Thank you
 
Upvote 0
OK. Give me a little time to work on this and I'll see what I can do.
 
Upvote 0
This is a rather long macro but I couldn't think of any other way to do what you requested. Give it a 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, shArr As Variant, i As Long
    Set odWS = ThisWorkbook.Sheets("OVERDUE")
    Set faWS = ThisWorkbook.Sheets("FOR ACTION")
    odWS.UsedRange.Offset(11).ClearContents
    faWS.UsedRange.Offset(11).ClearContents
    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 <> ""
        If strExtension = "MATERIAL.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "ST", "AR", "EL", "ME")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        ElseIf strExtension = "DOCUMENT.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "ST", "AR", "EL", "ME", "OTH", "REP")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        ElseIf strExtension = "SUBCON.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "AR", "EL", "ME", "GE", "MEP")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        ElseIf strExtension = "METHOD.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "AR", "EL", "ME", "SUM")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        ElseIf strExtension = "SHOP DWG.xlsx" Or strExtension = "AS-BUILT.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            With srcWB
                Set ws = Sheets("TR")
                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
                .Close savechanges:=False
            End With
        ElseIf strExtension = "INFORMATION.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            With srcWB
                Set ws = Sheets("RI")
                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
                .Close savechanges:=False
            End With
        ElseIf strExtension = "TESTING.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "AR", "EL", "ME")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        End If
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
 
Upvote 0
mumps said:
This is a rather long macro but I couldn't think of any other way to do what you requested. Give it a 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, shArr As Variant, i As Long
    Set odWS = ThisWorkbook.Sheets("OVERDUE")
    Set faWS = ThisWorkbook.Sheets("FOR ACTION")
    odWS.UsedRange.Offset(11).ClearContents
    faWS.UsedRange.Offset(11).ClearContents
    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 <> ""
        If strExtension = "MATERIAL.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "ST", "AR", "EL", "ME")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        ElseIf strExtension = "DOCUMENT.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "ST", "AR", "EL", "ME", "OTH", "REP")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        ElseIf strExtension = "SUBCON.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "AR", "EL", "ME", "GE", "MEP")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        ElseIf strExtension = "METHOD.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "AR", "EL", "ME", "SUM")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        ElseIf strExtension = "SHOP DWG.xlsx" Or strExtension = "AS-BUILT.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            With srcWB
                Set ws = Sheets("TR")
                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
                .Close savechanges:=False
            End With
        ElseIf strExtension = "INFORMATION.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            With srcWB
                Set ws = Sheets("RI")
                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
                .Close savechanges:=False
            End With
        ElseIf strExtension = "TESTING.xlsx" Then
            Set srcWB = Workbooks.Open(strPath & strExtension)
            shArr = Array("CV", "AR", "EL", "ME")
            With srcWB
                For i = LBound(shArr) To UBound(shArr)
                    Set ws = Sheets(shArr(i))
                    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 i
                .Close savechanges:=False
            End With
        End If
        strExtension = Dir
    Loop
    Application.ScreenUpdating = True
End Sub
Click to expand...

Nice mumps its working in my sample file but when I adjust row in my original file because the header name is not same so I insert a additonal row that will make it all the same header name.
The OVERDUE & FOR ACTION status in all rows is formula based criteria.
Here what i did:
1596957796917.png


All reference that have (11) I change to (12) but I encounter an error in this area .Cells(11, 1).CurrentRegion.AutoFilter od.Column, "OVERDUE"
error showing "autofilter method of range class failed"

Thank you mumps
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question
Copy and paste data through multiple workbooks
Replies
2
Views
184
CDaviess
C
H
  • Question
VBA split file based and send splitted file in separate emails
Replies
0
Views
143
harmless92
H
S
  • Question
VBA code to copy data from multiple workbooks and paste into master workbook
Replies
0
Views
794
Sunns
S
T
  • Question
Copy row values from one worksheet in one workbook to multiple workbooks based on file name
Replies
0
Views
152
thechad
T
R
  • Solved
I need to find a row based on multiple criteria, with a catch.
2
Replies
13
Views
472
rcrumbliss
R

Forum statistics

Threads
1,214,652
Messages
6,120,746
Members
448,989
Latest member
mariah3

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top