• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Loop all files in folder , Search for Instance & Copy Each Entire rows in active sheet

FILTER CRITERA.jpg error screen shot.jpg
Dear Sir @Marc L ,

(1) Re-upload code with un-comment on some lines.

(2) Where is criteria ?
(attached criteria's screen shot + ready made criteria excel file for just
copy paste criteria purpose in sheet 2).

(3) Attached 2 source file as sample (original each file have more then 50,000 lines so just some lines taken for just checking purpose. please change in criteria value for match with this 2 attached sample files for testing please put both in 1 folder & update path of that folder in code as target folder )

(3) Also attached where are error in code (Also Error Screen shot attached)

Code

Code:
'Testofadvfiltcopyinmaster
'LOOP IN FILES AND ADVANCE FILTER AND COPY TIO MASTER SHEET

Sub Test_of_Advfilt_Copy_in_Master()
    Dim file As Variant
    Dim path As String
    Dim i As Integer
    Dim wkbdest As Workbook
    Dim wbksrs As Workbook
    Dim Lastrow As Long
     
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  ' SET Which workbook Become Active & which will be open in Furutre
  'Activate New, Unsaved , This Worbook & Will Be Use For Furute Re-activate It
'
  Dim wkb As Workbook
    For Each wkb In Workbooks
        If Left(wkb.Name, 4) = "Book" Then
            Set wkbdest = wkb
        Else
            Exit For
        End If
        wkb.Activate
        Next wkb
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    i = 2
    path = ActiveSheet.range("a2").Value
        If Right(path, 1) <> "\" Then path = path & "\"
         
    file = Dir(path & "*.xls*")
 
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ActiveSheet.range("V1:AL5").copy
    While (file <> "")
    For Each file In wkbdest.Sheets(1).range("a2")
    If Error Then GoTo SkipFile

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    Workbooks.Open path & file
    Set wkbsrc = ActiveWorkbook
    '
'++++++++++++++++++++++++++++++++++++++++++++++
'REQUIRE:- Advanced Filter here
Sheets(1).Activate
ActiveSheet.range("BB1").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.range("BB1").Select
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Advance filter on multiple critera here
    Dim lrow As Long
    Dim criteriarows As Long
    Dim inputdatarange As range
    Dim criteria_range As range
    Dim rw As range
    Dim criteria_header As range
    Dim crange As range
    Dim criteria As New Collection
 

    With ActiveWorkbook.Sheets(1)
        lrow = .Cells(Rows.count, 1).End(xlUp).Row
        Set inputdatarange = .range("A1:AY" & lrow)
        criteriarows = .range("BB" & Rows.count).End(xlUp).Row
        Set criteria_range = .range("BB2:BB" & criteriarows).Resize(, 5)
        Set crange = .range("BN1:BN2").Resize(, 5)
    End With
    Columns.AutoFit

    For Each rw In criteria_range.Rows
    If Error Then GoTo Skiprw
        crange.Cells(2, 1).Resize(, 5) = rw.Value
        inputdatarange.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=crange, Unique:=False
        ActiveWorkbook.Sheets("Sheet1").range("A1:AY" & lrow).copy
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
wkb.Activate
Sheets(1).Activate
With ActiveSheet
'    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        Lastrow = .Cells.Find(What:="*", _
                      After:=.range("A1"), _
                      LookAt:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
'                      End If
                      End With
                ActiveSheet.Rows(Lastrow).Cells(2, 1).Select
                ActiveSheet.Paste
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        wkbsrc.Activate
    Next rw
'End Sub
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Skiprw:
'      Next rw

  ActiveWorkbook.Close
'      file = Dir()
    Set wkbdest = Nothing
    Set wbksrs = Nothing
      Wend
SkipFile:
            Next file
'Wend
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
error screen shot.jpg
 

Attachments

  • JUST CRITERA.xlsx
    17 KB · Views: 3
  • 01-DISP-INV INFO-ALL GUJ-46 COLUMNS-JAN-17.xlsx
    406.3 KB · Views: 4
  • 02-DISP-INV INFO-ALL GUJ-46 COLUMNS-FEB- 2017.xlsx
    297.8 KB · Views: 4

Message is obviously clear : a While codeline is missing !
First read VBA inner help for this statement,
after check your logic you wrote on a paper before to write any codeline
if this loop is needed : if yes, add the While codeline,
if not remove the Wend codeline …
 
Dear Sir @Marc L,

thanks for focus on error,
there are wend due to loop start through while
I also check "If" conditions should be closed with
"End If" & " With" closed by "End with".

is there best loop type to loop all only excel files ?

Regards
Chirag Raval
 
Choosing a loop depends from where you start to where you go,
just reading VBA inner help …

If you loop through all items of an object - a collection - or an array :
For Each
If you need to loop with an index : the common ForNext !

And to loop under a condition : WhileWend or DoLoop,
it depends on the condition itself.
See loop samples of Dir function and Range.Find method in VBA help …
 
Dear Sir @Marc L

After check as per all your above suggestions & re-checking many times, & updating...I can't outcome from "Wend Without While..."

Request to just copy paste this code without do anything in your module
& just run.. "
you also face this error. Though every thing, every conditions are seems ok..

Please Help.

Code:
Option Explicit
'Testofadvfiltcopyinmaster
'LOOP IN FILES AND ADVANCE FILTER AND COPY TIO MASTER SHEET

Sub Test_of_Advfilt_Copy_in_Master()
    Dim file As Variant
    Dim path As String
    Dim wkbdest As Workbook
    Dim wkbsrc As Workbook
    Dim Lastrow As Long
   
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
  ' SET Which workbook Become Active & which will be open in Furutre
  'Activate New, Unsaved , This Worbook & Will Be Use For Furute Re-activate It
'
'  Dim wkb As Workbook
'    For Each wkb In Workbooks
        If Left(ActiveWorkbook.Name, 4) = "Book" Then
            Set wkbdest = ActiveWorkbook
'        Else
'            Exit For
        End If
        wkbdest.Activate
'        Next wkb
'+++++++++++++++++++++++++++++++++++++++++++++++++++++
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
    path = ActiveSheet.range("a2").Value
        If Right(path, 1) <> "\" Then
        path = path & "\"
        End If
    file = Dir(path & "*.xls*")

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++
    ActiveSheet.range("V1:AL5").copy
    While (file <> "")
    For Each file In ActiveWorkbook.Sheets(1).range("A2")
    If Error Then
    GoTo Skip
    End If

'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    Workbooks.Open path & file
    Set wkbsrc = ActiveWorkbook
    '
'++++++++++++++++++++++++++++++++++++++++++++++
'REQUIRE:- Advanced Filter here
Sheets(1).Activate
ActiveSheet.range("BB1").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.range("BB1").Select
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Advance filter on multiple critera here
    Dim lrow As Long
    Dim criteriarows As Long
    Dim inputdatarange As range
    Dim criteria_range As range
    Dim rw As range
    Dim criteria_header As range
    Dim crange As range
    Dim criteria As New Collection


    With ActiveWorkbook.Sheets(1)
        lrow = .Cells(Rows.count, 1).End(xlUp).Row
        Set inputdatarange = .range("A1:AY" & lrow)
        criteriarows = .range("BB" & Rows.count).End(xlUp).Row
        Set criteria_range = .range("BB2:BB" & criteriarows).Resize(, 5)
        Set crange = .range("BN1:BN2").Resize(, 5)
    End With
    Columns.AutoFit

    For Each rw In criteria_range.Rows
    If Error Then GoTo Skip
        crange.Cells(2, 1).Resize(, 5) = rw.Value
        inputdatarange.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=crange, Unique:=False
        ActiveWorkbook.Sheets(1).range("A1:AY" & lrow).copy
     
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
wkbdest.Activate
Sheets(1).Activate
With ActiveSheet
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        Lastrow = .Cells.Find(What:="*", _
                      After:=.range("A1"), _
                      LookAt:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
                      End If
                      End With
                ActiveSheet.Rows(Lastrow).Cells(2, 1).Select
                ActiveSheet.Paste
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        wkbsrc.Activate
    Next rw

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Skip:
'        Next rw
'      Next file

  ActiveWorkbook.Close
      file = Dir()
    Set wkbdest = Nothing
    Set wkbsrc = Nothing

         
Wend
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
check your logic you wrote on a paper before to write any codeline
if this loop is needed : if yes, add the While codeline,
if not remove the Wend codeline …
So from your paper, if this loop is needed, what is its purpose ?
As I can't guess …

See also samples by
just reading VBA inner help …
See loop sample of Dir function in VBA help.
 
Dear All Experts,

I am wrongly do same thing as 2 separate loopsloops on same folder
First I try to get files via while Wend loop on folder then also
Again loop on same folder as For Each loop.

I remove While Wend ..its work .also I check after remove For each its also work

Wchich is best loop on files? While Wend or
For each....Or Do while Or While Wend?

Can you spread some light on which loop should use on which condition?

Please note that this thread's aim is not just only loopinglooping.

Regards,

Chirag Raval
 

As yet explained in post #29, DoLoop or WhileWend,
no matter on files as it depends on the condition.
Again, just see their samples in VBA inner help like the one for Dir
 
Dear All Experts,

Due to there are huge load of worrk in office where I work
and also my spouse's hospitalisation , i can not get some / little
Conscious momemt with at your guide lineline but hope may
Situation change for that I can resolve my this thread
& get solution which is very important for me.

Regards,

Chirag Raval
 
Dear Sir,

All below is seems Ok...but its go on "OnError Goto )"
its not run ...

request to please test yourself that even all structure of code is is okay
then why no result there?


Code:
Option Explicit
'Testofadvfiltcopyinmaster
'LOOP IN FILES AND ADVANCE FILTER AND COPY TIO MASTER SHEET

Sub Test_of_Advfilt_Copy_in_Master()
   
    Application.ScreenUpdating = False
    Application.EnableEvents = False
   
    Dim wkbDest As Workbook
    Dim wkbSource As Workbook
   
    Set wkbDest = ActiveWorkbook
   
    Dim LastRow As Long
'    Const strPath As String = ActiveSheet.range("A2").Value" 'change folder path to suit your needs
    Dim strPath As String
    Dim strExtension As Variant
   
    strPath = ActiveSheet.range("A2").Value 'change folder path to suit your needs
   
    wkbDest.Activate
   
    ActiveSheet.range("V1:AL5").copy
   
    ChDir strPath
    strExtension = Dir("*.xlsX")
   
    Do While strExtension <> ""
        Set wkbSource = Workbooks.Open(strPath & strExtension)
        On Error GoTo 0

        With wkbSource
'        DoEvents 'Ensure Workbook has opened before moving on to next line of code
        Sheets(1).Activate
   
''++++++++++++++++++++++++++++++++++++++++++++++
'REQUIRE:- Advanced Filter here
ActiveSheet.range("BB1").Activate
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.range("BB1").Select
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Advance filter on multiple critera here
    Dim lrow As Long
    Dim i As Integer
    Dim criteriarows As Long
    Dim inputdatarange As range
    Dim criteria_range As range
    Dim rw As Row
    Dim criteria_header As range
    Dim crange As range
    Dim criteria As New Collection
   
   
    With ThisWorkbook.Sheets("Sheet1")
        lrow = .Cells(Rows.count, 1).End(xlUp).Row
        Set inputdatarange = .range("A1:AY" & lrow)
        criteriarows = .range("BB" & Rows.count).End(xlUp).Row
        Set criteria_range = .range("BB2:BB" & criteriarows).Resize(, 5)
        Set crange = .range("BN1:BN2").Resize(, 5)
    End With
   
    For Each rw In criteria_range.Rows
        crange.Cells(2, 1).Resize(, 5) = rw.Value
        inputdatarange.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=crange, Unique:=False
        ActiveWorkbook.Sheets("Sheet1").range("A2:A" & lrow).SpecialCells(xlCellTypeVisible).EntireRow.copy
   
       
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
wkbDest.Activate

Sheets(1).Activate
With ActiveSheet
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        LastRow = .Cells.Find(What:="*", _
                      After:=.range("A1"), _
                      LookAt:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
                      End If
                      End With
                ActiveSheet.Rows(LastRow).Cells(2, 1).Select
                ActiveSheet.Paste
'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
        wkbSource.Activate
    Next rw

'++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'Skip:
'Next rw
'Next wkbSource
End With
wkbSource.Close , False

DoEvents
'Get next file name
      strExtension = Dir
     
    Set wkbDest = Nothing
    Set wkbSource = Nothing
Loop
'
On Error GoTo 0
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
 
Dear All Experts ,

Okay Got that where error come from , I forget to put "\" in path
even I also put checking statement

Code:
If Right(strPath, 1) <> "\" Then
        strPath = strPath & "\"
    End If

okay...code run till below attached screen shot

its can not define criteria range
error final.jpg


Please help what to do here?

Regards,
Chirag Raval
 
Hi ,

In an earlier post , the code is shown as :
Code:
criteriarows = .range("BB" & Rows.count).End(xlUp).Row
while here , you have posted an image which shows it to be :
Code:
criteriarows = .range("BB2" & Rows.count).End(xlUp).Row
The second line is incorrect , since you cannot have the construct :

"BB2" & Rows.count

The first line , which does not have the highlighted 2 is correct.

Narayan
 
Dear All Experts,

Mouse Hover displayed "rw=Noting" ....

I already declared variable rw as row...
so why its cannot count any row in collection of "Criteria_range.Rows" ?

Please Help..

Regards,
Chirag Rava
 
Dear All,,

Okay....variable rw declare as "Variant" & its run.....

but if there are no any row match with my criteria, then I put
error handling statement

"If Error Go To Skip:


skip have below
Skip:

next rw

but "Compile Error "Next Without For" displayed...

what can be do here?


Regards,

Chirag Raval
 
Dear All,,

Okay "Resume Next" Work ..but

constant pressin F8

"yellow highlighting Curser blink here" -->> Do While strExtension <> ""

...& exact on

Set wkbSource = Workbooks.Open(strPath & strExtension)

code direct going on

Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

I can't understands this behaviour ..

Please help..

Regards,
Chirag Raval
 
Dear All,

There are two nested loops....

(1) loop for files open & close (outer loop)
(2) loop for each criteria range's row copy -to final criteria block & advance filter (inner loop).

how to define

(1) Error can be raise On file Not Found ? (outer loop)
(2) Error can be raise if data not fund or not match with criteria range? (Inner Loop)

please help.

Regards,

Chirag Raval
 
Last edited:
Dear All Expert Sirs,

Point to be noted that VBA says that if want to use " This Workbook" statement , that only can be used when
Code (Macro) resides in that work book's any one sheet module. And I don't want that my
Code reside only in personnel.xlsb and not perticular saved workbook.

To copy every & each filtered instance , often need to jump between source to destination workbook.

How to do that without fail?

Regards,

Chirag Raval
 
Dear All,

Why "Dir" function take wrong file from clipboard??

actual files in folder is below

folder & file.jpg

but in vba wrong file take by code from clip board..


CATCH ANOTHER FILE FROM CLIPBOARD-2.jpg
 
Last edited:
As Dir function does not work from clipboard and it is faster than FSO !

See its sample in VBA inner help as you forgot the directory path within !
Edit : in fact no matter with ChDir statement,
which is not necessary if path is within Dir function.
Maybe a forbidden character within file name, so try renaming this file ...
 
Dear Sir @Marc L ,

Thank you very much for pointing to my mistake.

Excellent...Its Working magically and fast.

thank you for ..you really saved me to store wrong concept about VBA's Dir function is inefficient..

its really work ....

But Now ..destination sheet's last row. offset 1 ..I can not precisely establish..
at my below code.. where I mistake? I already pointing in code that for search last row, starts search form A6...but its always over write my previous pasted data...how to precisely paste data after last row of previous data on destination sheet?

Pease Help....

Regards,

Chirag Raval
 
Dear Sir @Marc L ,

Obviously anyone want data paste at destination sheet's " Column "A" to right but pasting start as base of under column "V"'s last row +1 because how may rows under column "V" (that is criteria rows ) is not fixed (it is dynamic)..

in short pasting is based on how many rows under column "V" , but
data pasting start from column "A"

for that purpose how can we modify below code OR something new technique can be use?

I face this situation is that if criteria under column v is less then 5, then code determine it self assume that last row under "V" is 5 other wise if criteria rows under column "v" is more then 5, the last criteria row is actual last because
what is in column "V" ? That are criteria structure ready to paste on every source workbook for advance filter.. & also this sheet become data collector (destination sheet) so if destination sheet's column "V" have less then 5 filled rows, pasting of data over write that blank rows that should not happen.

one more point is that if column "V" totally blank due to other criteria

as per below situation how can be decide last row based on whole criteria range end for determine last row? now criteria can be "V1" to Z's End" how we define last row of this whole range?

destination sheet.jpg


Code:
wkbDest.Activate

Sheets(1).Activate
With ActiveSheet
    If Application.WorksheetFunction.CountA(.Cells) <> 0 Then
        LastRow = .Cells.Find(What:="*", _
                      After:=.range("A1"), _
                      LookAt:=xlPart, _
                      LookIn:=xlFormulas, _
                      SearchOrder:=xlByRows, _
                      SearchDirection:=xlPrevious, _
                      MatchCase:=False).Row
                      End If
                      End With
          
                ActiveSheet.Rows(LastRow).offset(1, 0).Select
                ActiveSheet.Paste
                Application.CutCopyMode = False


Please help is there modification work on above code ? or some new approach should be applied?

Another point is that from first open source workbook, header row from that sheet should copy to destination sheet only 1 time.

In sort ......

(1) pasting should not over write criteria structure in destination sheet
(2) header row should be required to copy from first open source workbook in this destination sheet.
(3) after first instance of data copy to destination sheet ,how can its subsequent data will paste below previously pasted data?


hop you can understand

Regards,

Chirag Raval
 
Last edited:
Back
Top