Want to open specific file, filter, copy and paste based on value mention in the specific columns...filter value should be in same order

thomsonreuters

New Member
Joined
Dec 9, 2017
Messages
26
i have many files with different criteria to copy and paste into current workbook.

every time want to activate file name mention the Sheet 2 columnA (workbook name) and columnB (sheet name) and filter based on value present in the column C, copy and paste to Sheet 3 . Filter order should be same(creteria value is scuffled in source data). i have tries below codes but not working...am not good in VBA....just referring online examples and tried...

PLease could you any one help on this...

Sub looptest()

Dim LastRow As Long, LastrowA As Long

LastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row

For i = 2 To LastRow

With LastrowA = ThisWorkbook.Worksheets("sheet3").Range("A5").CurrentRegion.Rows.Count
Workbooks("Cells(i, 2).Value" & .xlsx).Sheets("& Cells(i, 3).Value").Activate
Selection.AutoFilter
Range("A2:AF" & LastRow).Select
Selection.AutoFilter field:=32, Criteria1:="Cells(i, 4).Value", Operator:=xlFilterValues
Selection.Offset(1, 0).SpecialCells(xlCellTypeVisible).Copy
ThisWorkbook.Worksheets("Sheet3").Range("A" & LastrowA + 1).PasteSpecial xlPasteFormulas
ThisWorkbook.Worksheets("Sheet3").Range("A" & LastrowA + 1).PasteSpecial xlPasteFormats
End With
Next

End Sub

File Name - Column ASheet - Column BFilter criteria - Column C
PB3-ALL-20_SAVIG.xlsxSAVIG QC CheckedWO2020060735
PB3-ALL-20_SAVIG.xlsxSAVIG QC CheckedUS2020095665
PB3-ALL-20_SAVIG.xlsxSAVIG QC CheckedUS2020094354
PB3-ALL-20_SAVIG.xlsxSAVIG QC CheckedUS2020098496
PB3-ALL-20_KPUSH.xlsxKPUSH QC CheckedUS2020098497
PB3-ALL-20_KPUSH.xlsxKPUSH QC CheckedUS2020091514
 

Excel Facts

Excel motto
Not everything I do at work revolves around Excel. Only the fun parts.
Selection.AutoFilter field:=32, Criteria1:="Cells(i, 4).Value", Operator:=xlFilterValues
Field 32 would be column AF
"Cells(i, 4).Value" quotes would make this text string
1-remove quotes
2-you need to determine the correct wb.worksheet this is located
Workbooks("Cells(i, 2).Value" & .xlsx) -remove quotes
 
Upvote 0
Field 32 would be column AF
"Cells(i, 4).Value" quotes would make this text string
1-remove quotes
2-you need to determine the correct wb.worksheet this is located
Workbooks("Cells(i, 2).Value" & .xlsx) -remove quotes

Thanks Dave.
Sorry, i am unable to follow you. please could you share full codes for my requirements if possible.
i have remote quotes...how to determine the correct wb.worksheet this is located

LastRow = ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row
For i = 2 To LastRow

Hope Cells(i, 2).Value & .xlsx - means "ThisWorkbook.Worksheets("Sheet2").Cells(Rows.Count, "B").End(xlUp).Row" - am i correct?

thanks
prakash
 
Last edited:
Upvote 0
There is no way without somebody else recreating your workbooks, to test out the code.
You may have to consider supplying a link to the "Sample" workbooks.
I usually use my google drive to share workbooks.

Without all the information, a decent answer cannot be given.
 
Upvote 0
There is no way without somebody else recreating your workbooks, to test out the code.
You may have to consider supplying a link to the "Sample" workbooks.
I usually use my google drive to share workbooks.

Without all the information, a decent answer cannot be given.


Thanks Dave. Here am sharing workbook using google drive...

Google drive link:


Attached 3 sheets respective below...

Consolidation Test :
Sheet2 - Where consolidated file present(final result) from A5 cell.
Sheet2: Reference sheet for vba
B2:B - File name, C2:C - Sheet name, D2:D - Criteria

PB3-ALL-20_A.xlsx and PB3-ALL-20_B.xlsx - Where needs to extract the data.

I have attached 2 source files as an example, but i have multiple workbook with different filter criteria.

My requirement is that kind of loop, code should refer each file with respective criteria and extract the data to consolidation file, sheet 1 from A5.
Code should refer and work one by one line till last row in B column in consolidation test workbook since i need same order as per criteria list like D1 criteria first and D2 criteria 2...
Also i need to copy with format change and formula should be available as it is...there is no change even cell colors, formula everything..
Hope my requirement is clear now...
PLease help on this, it will reduce huge amount hrs for me....its urgent so pls reply asap....thanks for your help on this...

Kindly let me know still its not clear...

Thanks
JP
 
Upvote 0
You can try this,
Make sure all the open workbooks match what is in column B and also your data and what is in column D must match, even leading spaces or following spaces will give you the incorrect results.
VBA Code:
Sub looptest()
    Dim wb As Workbook, ws As Worksheet
    Dim LastRow As Long, LastrowA As Long
    Dim rng As Range, c As Range, fltr As Range
    Dim DstSh As Worksheet
    Dim bk As Workbook, bs As Worksheet
    Dim cpyRng As Range, LstRw As Long, x
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet2")
    Set DstSh = wb.Sheets("Sheet3")
    With ws
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
        Set rng = .Range("B2:B" & LastRow)

        For Each c In rng.Cells
            Set bk = Workbooks(c.Value & ".xlsx")
            Set bs = bk.Sheets(c.Offset(, 1).Value)

            With bs
                LastrowA = .Cells(.Rows.Count, "AF").End(xlUp).row
                Set cpyRng = .Range("A2:AF" & LastrowA)
                x = Application.WorksheetFunction.CountIf(.Range("AF1:AF" & LastrowA), c.Offset(, 2))
                .Range("A1").AutoFilter field:=32, Criteria1:=c.Offset(, 2)

            End With
            With DstSh
                LstRw = .Cells(.Rows.Count, "AF").End(xlUp).row + 1
                If x <> 0 Then
                    cpyRng.Copy
                    .Range("A" & LstRw).PasteSpecial xlPasteFormulas
                    .Range("A" & LstRw).PasteSpecial xlPasteFormats
                End If
            End With
            
            x = 0
        Next
        
    End With

End Sub
 
Upvote 0
Thank u so much Dave...I won't forget this help...I will try and let u know...thanks again.
JP
 
Last edited by a moderator:
Upvote 0
You can try this,
Make sure all the open workbooks match what is in column B and also your data and what is in column D must match, even leading spaces or following spaces will give you the incorrect results.
VBA Code:
Sub looptest()
    Dim wb As Workbook, ws As Worksheet
    Dim LastRow As Long, LastrowA As Long
    Dim rng As Range, c As Range, fltr As Range
    Dim DstSh As Worksheet
    Dim bk As Workbook, bs As Worksheet
    Dim cpyRng As Range, LstRw As Long, x
    Set wb = ThisWorkbook
    Set ws = wb.Sheets("Sheet2")
    Set DstSh = wb.Sheets("Sheet3")
    With ws
        LastRow = .Cells(.Rows.Count, "B").End(xlUp).row
        Set rng = .Range("B2:B" & LastRow)

        For Each c In rng.Cells
            Set bk = Workbooks(c.Value & ".xlsx")
            Set bs = bk.Sheets(c.Offset(, 1).Value)

            With bs
                LastrowA = .Cells(.Rows.Count, "AF").End(xlUp).row
                Set cpyRng = .Range("A2:AF" & LastrowA)
                x = Application.WorksheetFunction.CountIf(.Range("AF1:AF" & LastrowA), c.Offset(, 2))
                .Range("A1").AutoFilter field:=32, Criteria1:=c.Offset(, 2)

            End With
            With DstSh
                LstRw = .Cells(.Rows.Count, "AF").End(xlUp).row + 1
                If x <> 0 Then
                    cpyRng.Copy
                    .Range("A" & LstRw).PasteSpecial xlPasteFormulas
                    .Range("A" & LstRw).PasteSpecial xlPasteFormats
                End If
            End With
           
            x = 0
        Next
       
    End With

End Sub

Hi Dave,

I have tried this code. It's working for first 2 criteria only. Unable to extract more than 2 (stopped with US2020095665). Please could you help on this

Thanks
JP
 
Upvote 0
I don't know,
Today, I can't even get past this line today!
VBA Code:
            Set bk = Workbooks(c & ".xlsx")
Keep getting subscript out of range even though the workbook names match exactly.
 
Upvote 0

Forum statistics

Threads
1,213,536
Messages
6,114,215
Members
448,554
Latest member
Gleisner2

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