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
 
Figured out why I could not get past that line, I had .xlsx in the cells as well.
Looking into original issue
 
Upvote 0

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Hi Dave,

I have tried this code. It's working for first 2 criteria only. Unable to extract more than 2 (stopped with US2020095665). Also if i mention 2nd criteria from another workbook, again its not working. Please could you help on this

Thanks
JP
Figured out why I could not get past that line, I had .xlsx in the cells as well.
Looking into original issue


Actually i dont have .xlsx in my sheet, but still its working for first two criteria only if it's in same workbook. If we change the workbook then its not working for 2 criteria as well.

thanks
JP
 
Upvote 0
Like I mentioned in post#6 the data has to match the criteria, leading spaces or following spaces will result in incorrect results.

Maybe wildcards will help

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)
            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
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 both suggestion codes again and removed all spaces if any.

First suggestion (without astrix) working almost fine but not extract the 3rd criteria alone. It's extracting 1,2,4,5....3 missing....i have checked and removed all spaces...
I dont know why this error...

PLease can u help on this.

Note : 2nd suggestion is not working properly.....its copying data even not mention in the criteria column...

thanks
JP
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,218
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