1. Welcome to Chandoo.org Forums. Short message for you

    Hi Guest,

    Thanks for joining Chandoo.org forums. We are here to make you awesome in Excel. Before you post your first question, please read this short introduction guide. When posting or responding to questions please remember our values at Chandoo.org are: Humility, Passion, Fun, Awesomeness, Simplicity, Sharing Remember that we have people here for whom English is not there first language and we need to allow for this in our dealings.

    Yours,
    Chandoo
  2. 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...

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

Loop on All files of folder ,But Process Only specifically Listed (Partial Named)Files

Discussion in 'VBA Macros' started by Chirag R Raval, Mar 17, 2018.

  1. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear All Experts,

    Though, As Routine for Loop, Loop on All files of folder , but requirement is Process Only specifically Listed (Partial Named)Files On Sheet, Not All Files Of Folder.


    I have 2 codes , first code fill the series of dates between given 2 dates (Cell (“B3”) have start date & Cell (“B4”) have end date ) code return series or array of all dates between this two dates in vertical list form on sheet as start date to end date. You can name this code as Auto-fill Code”


    And 2nd code another code open & process each file , as per given list as full path & full file name with extension. Given on sheet as file list. You can name this code as “File Processor Code”


    Both code till not any relation to each other ,but requirement here is this code (file name process) should process each listed files which’s file names are partially mentioned .


    I have 1 folder named “2017” & 12 files (we can have more) each files have monthly goods dispatch data in it,

    File name’s first 8 characters look like a date form like “01052017”, or “01022018” etc.


    For example (Like) full fine name , in folder named “2017” , is “01102017-DISP-INV INFO-ALL GUJ-46 COLIMNS-OCT-2017.xlsx”, Another file for example “01082017-DISP-INV INFO-ALL GUJ-46 COLIMNS-AUG-2017.xlsx” etc..


    SCREEN SHOT OF FILE-FOLDER STRUCTURE

    file folder structure.jpg


    If Partial name on sheet , as just first 8 characters of full filename like “01102017”, or “018082017” etc..


    Processing code should auto initialize full name based on partial name on sheet & process it.


    First requirement is , in date code , I can not format dates filled/retuned by code in format “ddmmyyyy” OR “

    In other words Like number “01052017” (remember that filled / returned as list dates are not is real date format, its may be number format…or text type…


    Code no 1st “Auto fill dates Code ”

    Code (vb):

    'AUTOFILL DATES -LIST AS MONTH YEAR BETWEEN GIVEN TWO DATES ON SHEET
    Sub AutoFillDateMonthyear()
    Dim sc As Range
    Dim Stdt As Date
    Dim Edt As Date
    Dim dDate As Date
    Dim off As Integer

    Stdt = ActiveSheet.Range("B3") ' start date
    Edt = ActiveSheet.Range("B4") ' end date
    Set sc = ActiveSheet.Range("A8") ' start cell
    '
    Range("A8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    '
    off = 0
    '
    For dDate = Stdt To Edt
      If Format(dDate, "dd") = "01" Then
      sc.Offset(off, 0) = Format(dDate, "mm yy")
      ' WHY CAN NOT CONVERT IT LIKE BELOW?
    '  sc.Offset(off, 0) = Format(dDate, "DDMMYYYY") as LOOK "01052017"???

      off = off + 1
      End If
    Next dDate
    '
    'sc.Resize(off, 1).NumberFormat = "mm" & " - " & "yy"
    ' 'WE CAN MODIFY DATE FORMAT BELOW
    ' sc.Resize(off, 1).NumberFormat = "mm" & " - " & "yy"
    '
    End Sub
     

    SCREEN SHOT OF END RESULT FOR AUTOFILL DATE CODE

    RESULT & MACRO FOR AUTOFILL MONT YEAR BETWEEN GIVEN TWO DATES.jpg

    Code No 2 "
    “File Processor Code”
    Code (vb):
    Sub LoopOpenAndProcessFilesAsListok()

        Dim myDir As String
        Dim r As Range
        Dim fn As String
        Dim msg As String
        Dim destwbk As Workbook
        Dim SWBK As Workbook
     
     
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
     
        Set destwbk = ActiveWorkbook
    '    destwbk.Activate

        myDir = "D:\INV INFO 46 COLUMNS ALL GUJARAT-MONTH WISE EXCEL FILE-2017\MONTH WISE SEPRATE FILES\2017\"
     
        For Each r In Range("c2", Range("c" & Rows.count).End(xlUp))
            fn = Dir(myDir & r.Value)
                If fn = "" Then
                    msg = msg & vbLf & r.Value
                Else
                    With Workbooks.Open(myDir & fn)
                       
                        Set SWBK = ActiveWorkbook
             
                            SWBK.Sheets(1).Range("A1:D5").Copy
    '
    '            destwbk.Activate
    '
               If destwbk.Sheets(1).Range("A10") = "" Then
             
                destwbk.Sheets(1).Range("A10").PasteSpecial xlPasteValues
             
                Else
             
                destwbk.Sheets(1).Range("A10").End(xlDown).Offset(1, 0).PasteSpecial xlPasteValues
                                       
                    SWBK.Close False
                 
                    End If
                 
                    End With
             
            End If
        Next
        If Len(msg) Then
            MsgBox "Not found" & msg
        End If
     
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
     
    End Sub

     
    (1) 1st requirement about auto fill date code ..how to format dates as like "01012017" OR like "########"

    (2) 2nd requirement is how to modify Process files code , that loop on given list,
    (return by auto-fill date code (return as like "01052017" ) which become partial name for process file code. (Partial as first 8 character of file name if partial match with full, process that file).

    Hope your help regarding this thread..

    Regards,

    Chirag Raval
    Last edited: Mar 17, 2018
  2. Marc L

    Marc L Excel Ninja

    Messages:
    3,891
    Hi !​
    Code (vb):
    Sub DemoQ1()
        MsgBox Format(#9/1/2017#, "ddmmyyyy")
    End Sub
    For partial name just use Dir VBA function with wildcards,
    for example Dir("01012017*.xlsx")
  3. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir @Marc L ,

    Thank you very much for your guide line...Its Working...after modify as per your little focus towards it...I change in Auto Fill Date code as below

    Code (vb):


    For dDate = Stdt To Edt
        If Format(dDate, "dd") = "01" Then
       
            sc.Offset(off, 0) = Format(dDate, "ddmmyyyy") & "*"  
               
          off = off + 1
        End If
    Next dDate
     
    It is format date as "########" and also put "*" after that date
    & it become partial name for 2nd code (file proceesing code) (first 8 char) of full name of file with wild card "*" for loop each that all & each date lines & process each related files. Thanks to you...work like we expected.

    here its screen shot..

    RESULT AS EXPECTED-DATE WITH WILD CARD OK.jpg


    Since, this both code meet solutions...as simple construct..

    I want to apply same process on my below one requirement if date written
    in this format like =">"& DATEVALUE("01-01-2017").

    whole requirement is in below screen shot

    HOW TO ACHIVE AS THIS TYPE.jpg

    how to modify date code that recognise Start Date & End Date written as this format =">"& DATEVALUE("01-01-2017") ??

    Please Guide..

    Regards,

    Chirag Raval
  4. Marc L

    Marc L Excel Ninja

    Messages:
    3,891
    Not sure of what you need but

    E2 formula : =DateValue("01-01-2017")

    E2 cell formatting : ">"dd/mm/yyyy

    VBA : MsgBox Format([E2].Value, "ddmmyyyy")
    Chirag R Raval likes this.
  5. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir, @MarcL

    Sorry for I can't describe clearly ..

    In other words if we want , how can we extract just 01-01-2017 form cell
    where formula written as =">"& DATEVALUE("01-01-2017")
    (like in cell ("E2") , in this case )

    we just want to return 01-01-2017 anywhere in sheet, any cell OR in variable.. if we retrieve this, we can apply this result
    as date as Start Date in "B3" & End Date..in "B4"
    so based on this date “Auto fill dates Code ” can do its job.

    hope I can described as your understandable format.

    Please revert if you feel any further clarification.

    Regards,

    Chirag Raval
  6. Marc L

    Marc L Excel Ninja

    Messages:
    3,891
    As yet explained in my previous post just with a real date value,
    a formatting and the desired cell property …​
    Code (vb):
    Sub DemoD1()
        With [A1]
            .Value = 43178
            .NumberFormat = """>""dd/mm/yyyy"
            MsgBox .Value2
            MsgBox .Value
            MsgBox .Text
            S$ = .Value
            MsgBox S
        End With
    End Sub
    Chirag R Raval likes this.
  7. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir @MarcL

    Thanks, we are near requirement...

    I already try as per your ...With [A1].Value = 43178, but there are more
    in that cell before "43178" , there are "=" signs, there are ">" signs etc....,

    We just want To Extract Date From "E2"..& use this extraction in B2.. as literally entered by keyboard in B2 like 01/02/2017 ..

    More precise requirement in in below screen shot..

    REQUIREMENT.jpg

    How to just extract date from "E2"?

    Though, there are anything,before & after date in "E2" either it is formula or anything , we want just require date from "E2" .....& apply that extracted on "B2".

    I also & already try to find on web, but not found "How To Extract String from Formula?"


    I already try to use search function & study VBA help..for search
    in this help chapter...


    " You can use the wildcard characters, question mark (?) and asterisk (*), in find_text. A question mark matches any single character; an asterisk matches any sequence of characters. If you want to find an actual question mark or asterisk, type a tilde (~) before the character.
    "
    but there are not found help for use for search "#" char to get position of that

    I also try to use like operator, try to find but...can not get result

    hope you co-operation

    Regards,
    Last edited: Mar 21, 2018
  8. Marc L

    Marc L Excel Ninja

    Messages:
    3,891
    The easy way is first to remove your bad formula in cell E2
    as to exploit a data as a date a real number / date must be filled
    without any other chars like ">", "<", "=" and format cell with
    one of these others chars like already shown in my posts …

    If you can't, if E2 cell is not a valid date but just a text so just
    via Mid([E2].value, 2) like you can read in VBA inner help …

    From a formula use the cell property with the same name …
  9. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir,

    Yes , Great Point...Great Learning, Thanks for your guide line..

    I can not remove literal entered =">" from "E2" because its criteria of advance filter used by another data fetching macro..so it can not be bad formula.

    Date Fill code just require simple date, either its text or date, so I do & go with as per your 2nd option ,without remove anything from "E2" & Get literal text "01/01/2017" as below screen shot which I can put in "B2".

    I just get this result from below simple code construct..

    Code (vb):

    Option Explicit

    Sub test3()
    Dim s As String
    s = Format(Mid([E2].Value, 2), "dd/mm/yyyy")
    MsgBox s
    End Sub
     
    below is screen shot of return...

    Amazing,Got it, thanks.jpg

    But one question in mind that how to catch exact position of "#" (any number) in string? because some function not allow wild cards if you want to just get position of first meet any number char.., I wander that ,if , Excel's some function , support wild cards char like "?", & "*", why can not support "#' in excel ? or may be I have not knowledge of that...hope you spread some light on this..

    I will be back after try to successful running my next portion macro (May be it will go towards, Loop on Array & Dir ) as this thread's requirement to loop on list of partial file names.

    how can I say that? because , till now loop work on just simple range as list of files which contain partial file names, but if you want to work on direct folder ,
    then?

    Till then, thank you very much

    Regards,

    Chirag Raval
    Last edited: Mar 21, 2018
  10. Marc L

    Marc L Excel Ninja

    Messages:
    3,891

    Either a loop to check each char or using a regular expression
    via the RegExp VBScript Windows object …​
  11. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir @Marc L & Sir @NARAYANK991 ,

    Below Code work properly till, values found as per critera range, if value not found , its behaviour is out of control & fetch all data of that file instead as per criteria.

    I also upload 3 data files as sample for put in folder & give path in A2 of in which critera resides.



    (1) FIRST MACRO FOR JUST PREPARE CRITERA STRUCTURE FOR ADVANCE FILTER ON EVERY FILE

    Code (vb):

    'READY MADE STRUCTURE FOR BOTH SMALL DETAIL OR  BIG DETAIL FOR 'BOSS

    Sub STGGujSmallBuyBigBossQueryStrDTok()
    With ActiveWorkbook.ActiveSheet
        .Range("D1").FormulaR1C1 = "Customer"
        .Range("E1").FormulaR1C1 = "Inv. Date"
        .Range("F1").FormulaR1C1 = "Inv. Date"
        .Range("G1").FormulaR1C1 = "Sal Doc Ty"
        .Range("H1").FormulaR1C1 = "Material"
        .Range("I1").FormulaR1C1 = "Batch"
        .Range("D2").FormulaR1C1 = ">=0"
        .Range("E2").FormulaR1C1 = "="">=""& DATEVALUE(""01-01-2017"")"
        .Range("F2").FormulaR1C1 = "=""<=""& DATEVALUE(""31-12-2017"")"
        .Range("G2").FormulaR1C1 = "YBKG"
        .Range("H2").FormulaR1C1 = "005384-0008"
        .Range("I2").FormulaR1C1 = "*"
      .Range("D1:I5").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        End With
        Cells.EntireColumn.AutoFit
        Range("D1:I5").Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With ActiveSheet
       
        Range("D1:I1").Select
        Selection.Font.Bold = True
        Range("D1:I5").Select
        Selection.Copy
        Range("K1").Select
        ActiveSheet.Paste
       
          Application.CutCopyMode = False
        Cells.Select
        Cells.EntireColumn.AutoFit
        Range("I1").Select
       
         
        Range("K2:P5").Cells.ClearContents
        Range("K3:P5").Cells.ClearFormats
       
        With ActiveSheet.Range("A1")
        .Font.Bold = True
        .Font.Size = "16"
        End With
       
        Range("A1").Select
        ActiveCell.FormulaR1C1 = _
            "WARNING-PLEASE CHECK OF AUTOMETIC CHANGE PATH? (AT END FULL-SMALL)" & Chr(10) & _
            "FOR BIG OR SMALL DETAIL-DIRECT LINK TO A2" & Chr(10) & _
            "MUST ENTER MONTH'S END DATE AT TO DATE"
        ActiveCell.RowHeight = 62
       
        With ActiveSheet.Range("D7:I7")
        .MergeCells = True
        .FormulaR1C1 = "MUST be ENTER MONTH'S END DATE AT TO DATE"
        .HorizontalAlignment = xlCenter
        .BorderAround _
    ColorIndex:=1, Weight:=xlMedium
       
        End With
       
        Range("A2").Value = "D:\INV INFO-FULL-SMALL\MONTH WISE\2017 FULL"
        Range("A4").Value = "YOU CAN SEE RESULT IN NEXT SHEET"
       
        With ActiveSheet.Range("A4")
       
        .Font.Bold = True
        .Font.Size = "16"
            Columns.AutoFit
         
    End With
             
        End With
    End Sub
     
    As per above code your new files new sheet look like below screen shot

    DATA FETCHER.png

    Attached Files:

  12. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir,

    2ND MACRO FOR FETCH DATA THROUGH ADVANCE FILTER FROM FILE AS
    PER CRITERA

    Code (vb):

    Option Explicit
    Option Compare Text
    ''WARNING :- FIRST RUN READY MADE CRITERA STRUCTURE MACRO FOR PREPARE CRITERA

    Sub STGGujSmallQueryMultiCrok()

    '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    'Sub LoopOpenAndProcessFilesAsListok()

    'FIRST SET FILE NAMES AS List
    'https://www.mrexcel.com/forum/excel-questions/706652-vba-code-list-first-day-each-month-between-start-date-end-date.html
    'LIST OF MONTH OR YER BETWEEN TWO DATE
    'EXTRACT & FILL MONTH YEAR BETWEEN TWO DATES
    'LIST MONTH YEAR BETWEEN TWO DATES
    'Sub FillMonthYearbetween2DtInVar()
    '
    Dim sc As Range
    Dim Stdt As Date
    Dim Edt As Date
    Dim dDate As Date
    Dim off As Integer
    Dim dtstar As String

    ' Stdt = ActiveSheet.Range("B3")  ' start date
    ' Edt = ActiveSheet.Range("B4")  ' end date
    Set sc = ActiveSheet.Range("A8")  ' start cell

    Stdt = Format(Mid([E2].Value, 3), "dd/mm/yyyy") 'REMEMBER-IF E2 HAVE 2 TIMES ",", THEN IN THIS FORMULA [E2].Value, 3) IF 2 TIMES [E2].Value, 2)
    Edt = Format(Mid([F2].Value, 3), "dd/mm/yyyy") 'REMEMBER-IF E2 HAVE 2 TIMES ",", THEN IN THIS FORMULA [E2].Value, 3) IF 2 TIMES [E2].Value, 2)


    Range("A8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents

    off = 0

    For dDate = Stdt To Edt
        If Format(dDate, "dd") = "01" Then
       
            sc.Offset(off, 0) = Format(dDate, "ddmmyyyy") & "*.xls*" 'WORK OK
                     
          off = off + 1
        End If
    Next dDate

    Set sc = Nothing
    '++++++++++++++++++++++++++++++++++++++++++++++++
    'https://powerspreadsheets.com/excel-vba-replace-substitute/#Macro-Example-to-Replace-String-in-Cell-Specifying-a-Starting-Position-for-Search
    'FindReplaWithStartPosition
    'Sub replaceStringInCellWithStartPosition()

        'Source: https://powerspreadsheets.com/
       'For further information: https://powerspreadsheets.com/excel-vba-replace-substitute/

        'declare object variable to hold reference to cell you work with
       Dim myCell As Range

        'declare variables to hold parameters for string replacement (string to replace, replacement string, start position for search of string to replace, and number of replacements)
       Dim myStringToReplace As String
        Dim myReplacementString As String
        Dim myStartPosition As Long
        Dim myNumberOfReplacements As Long

    '    'identify cell you work with
    '    Set myCell = ThisWorkbook.Worksheets("Excel VBA Replace").Range("A6")
       Set myCell = ActiveSheet.Range("A2")

        'specify parameters for string replacement (string to replace, replacement string, start position for search of string to replace, and number of replacements)
    '    myStringToReplace = "replace"
    '    myReplacementString = "substitute"
     
        myStringToReplace = "FULL"
        myReplacementString = "SMALL"
       
        myStartPosition = 28
        myNumberOfReplacements = 1

        'return and concatenate the following strings, and assign the resulting (concatenated) string to Range.Value property of cell you work with
           '(i) string containing the first characters within the cell you work with (from first position up to the character before the start position for search of string to replace)
           '(ii) string resulting from working with the Replace function and the parameter for string replacement you specify
       myCell.Value = Left(String:=myCell.Value, Length:=myStartPosition - 1) & Replace(Expression:=myCell.Value, Find:=myStringToReplace, Replace:=myReplacementString, Start:=myStartPosition, Count:=myNumberOfReplacements)

    'End Sub
    '++++++++++++++++++++++++++++++++++++++++++++++++

    'https://www.ozgrid.com/forum/forum/help-forums/excel-general/101320-vba-open-files-from-a-list
    'OPEN FILES LOOP FILES FOLDER OPEN AS PER LIST
    'LOOP OPEN & PROCESS FILES AS PER LIST ON SHEET
    'OPEN & PROCESS FILES AS PER LIST ON SHEET RANGE
    'Sub LoopOpenAndProcessFilesAsListok()

        Dim myDir As String
        Dim R As Range
        Dim fn As String
        Dim msg As String
        Dim destwbk As Workbook
        Dim SWBK As Workbook
       
        Dim destsht As Worksheet
        Dim swsht As Worksheet
        Dim mainsht As Worksheet
       
       
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
       
        Set destwbk = ActiveWorkbook
        Set mainsht = destwbk.Sheets(1)
        Set destsht = destwbk.Sheets(2)
       
        mainsht.Activate
       
        myDir = ActiveSheet.Range("A2").Value
       
        If Right(myDir, 1) <> "\" Then
            myDir = myDir & "\"
        End If
       
        On Error GoTo skip:
       
        For Each R In ActiveSheet.Range("A8", Range("A" & Rows.Count).End(xlUp))
           
            fn = Dir(myDir & R.Value)
           
                If fn = "" Then
                    msg = msg & vbLf & R.Value
                   
                Else
                   
            With Workbooks.Open(myDir & fn) 'YOU CAN PUT HERE WILD CARD "*" OR OTHER LIKE (& "*")
                                                                                             
                Set SWBK = ActiveWorkbook
                Set swsht = SWBK.Sheets(1)
                       
                        mainsht.Range("D1:P5").Copy
                       
                        swsht.Range("K1").Activate
                                            ActiveSheet.Paste
                       

                                    Application.CutCopyMode = False
                                    ActiveSheet.Range("K1").Select
                                   
                                    End With
                                   
                                    End If
    '++++++++++++++++++++++++++++++++++++++++++++++++
         
      'ADVANCE FILTER ON MULTIPLE CRITERA ,  multi critera , multi_critera & SEPRATE THAT FILE BASIC CODE
    'https://chandoo.org/forum/threads/formula-for-advance-filter-on-multiple-criteria-for-separate-each-filtered-instance-as-new-file.36314/#post-218502
    'ASKED FROM CHIRAG
    'ANSWERED BY NARAYANK991
    'Sub STG_MasterOrdStaMultCriSepFile()

        Dim lrow As Long
        Dim i As Integer
        Dim criteriarows As Long
        Dim inputdatarange As Range
        Dim criteria_range As Range
        Dim rw As Variant
        Dim criteria_header As Range
        Dim crange As Range
        Dim Criteria As New Collection
       
       
        With swsht
        If .AutoFilterMode Then .Cells.AutoFilter
            lrow = .Cells(Rows.Count, 1).End(xlUp).Row
            Set inputdatarange = .Range("A1:I" & lrow)
            criteriarows = .Range("K" & Rows.Count).End(xlUp).Row
            Set criteria_range = .Range("K2:K" & criteriarows).Resize(, 6)
            Set crange = .Range("R1:R2").Resize(, 6)
        End With
       
        On Error GoTo skip
       
        For Each rw In criteria_range.Rows
       
            crange.Cells(2, 1).Resize(, 6) = rw.Value
            inputdatarange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=crange, Unique:=False
           
        If destsht.Range("A1") = "" Then

            swsht.Range("A1:I" & lrow).Copy
                                   
            Else
                                 
                swsht.Range("A2:I" & lrow).Copy
                End If


        If Len(msg) Then
            MsgBox "Not found" & msg
        End If
       
       
        destsht.Activate


    If destsht.Range("A1") = "" Then

    destsht.Range("A1").Activate


    Else
    'REMEMBER IF NO DATA FOUND THEN ("a").END METHOD FAIL &
    'ROWS 1 WILL BE OVER WRITTEN THEN SECURED & MUST BE USED ROWS COUNT METHOD AS BELOW

    destsht.Range("A" & Rows.Count).End(xlUp).Offset(1).Activate

    End If

    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

         
                    Application.CutCopyMode = False
                   
        SWBK.Activate
           
            If ActiveSheet.FilterMode Then ActiveSheet.showAllData
                         
               
        Next rw
                           
       
        '++++++++++++++++++++++++++++++++++++++++++++++++
    skip:
    'resume to next rw
    Resume Next
    'Next swbk
    Resume Next
    'End With


    If ActiveSheet.FilterMode Then ActiveSheet.showAllData
            ActiveSheet.AutoFilterMode = False
           
    SWBK.Close SaveChanges:=False

    DoEvents
       
    destwbk.Sheets(1).Activate

    Next R
    End sub
     
    if any data not match with criteria code fetch all data of that file.
    how to modify this code?

    Regards,

    Chirag Raval
  13. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir,

    2ND MACRO FOR FETCH DATA THROUGH ADVANCE FILTER FROM FILE AS
    PER CRITERA

    Code (vb):

    Option Explicit
    Option Compare Text
    ''WARNING :- FIRST RUN READY MADE CRITERA STRUCTURE MACRO FOR PREPARE CRITERA

    Sub STGGujSmallQueryMultiCrok()

    '+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    'Sub LoopOpenAndProcessFilesAsListok()

    'FIRST SET FILE NAMES AS List
    'https://www.mrexcel.com/forum/excel-questions/706652-vba-code-list-first-day-each-month-between-start-date-end-date.html
    'LIST OF MONTH OR YER BETWEEN TWO DATE
    'EXTRACT & FILL MONTH YEAR BETWEEN TWO DATES
    'LIST MONTH YEAR BETWEEN TWO DATES
    'Sub FillMonthYearbetween2DtInVar()
    '
    Dim sc As Range
    Dim Stdt As Date
    Dim Edt As Date
    Dim dDate As Date
    Dim off As Integer
    Dim dtstar As String

    ' Stdt = ActiveSheet.Range("B3")  ' start date
    ' Edt = ActiveSheet.Range("B4")  ' end date
    Set sc = ActiveSheet.Range("A8")  ' start cell

    Stdt = Format(Mid([E2].Value, 3), "dd/mm/yyyy") 'REMEMBER-IF E2 HAVE 2 TIMES ",", THEN IN THIS FORMULA [E2].Value, 3) IF 2 TIMES [E2].Value, 2)
    Edt = Format(Mid([F2].Value, 3), "dd/mm/yyyy") 'REMEMBER-IF E2 HAVE 2 TIMES ",", THEN IN THIS FORMULA [E2].Value, 3) IF 2 TIMES [E2].Value, 2)


    Range("A8").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents

    off = 0

    For dDate = Stdt To Edt
        If Format(dDate, "dd") = "01" Then
     
            sc.Offset(off, 0) = Format(dDate, "ddmmyyyy") & "*.xls*" 'WORK OK
                     
          off = off + 1
        End If
    Next dDate

    Set sc = Nothing
    '++++++++++++++++++++++++++++++++++++++++++++++++
    'https://powerspreadsheets.com/excel-vba-replace-substitute/#Macro-Example-to-Replace-String-in-Cell-Specifying-a-Starting-Position-for-Search
    'FindReplaWithStartPosition
    'Sub replaceStringInCellWithStartPosition()

        'Source: https://powerspreadsheets.com/
       'For further information: https://powerspreadsheets.com/excel-vba-replace-substitute/

        'declare object variable to hold reference to cell you work with
       Dim myCell As Range

        'declare variables to hold parameters for string replacement (string to replace, replacement string, start position for search of string to replace, and number of replacements)
       Dim myStringToReplace As String
        Dim myReplacementString As String
        Dim myStartPosition As Long
        Dim myNumberOfReplacements As Long

    '    'identify cell you work with
    '    Set myCell = ThisWorkbook.Worksheets("Excel VBA Replace").Range("A6")
       Set myCell = ActiveSheet.Range("A2")

        'specify parameters for string replacement (string to replace, replacement string, start position for search of string to replace, and number of replacements)
    '    myStringToReplace = "replace"
    '    myReplacementString = "substitute"
     
        myStringToReplace = "FULL"
        myReplacementString = "SMALL"
     
        myStartPosition = 28
        myNumberOfReplacements = 1

        'return and concatenate the following strings, and assign the resulting (concatenated) string to Range.Value property of cell you work with
           '(i) string containing the first characters within the cell you work with (from first position up to the character before the start position for search of string to replace)
           '(ii) string resulting from working with the Replace function and the parameter for string replacement you specify
       myCell.Value = Left(String:=myCell.Value, Length:=myStartPosition - 1) & Replace(Expression:=myCell.Value, Find:=myStringToReplace, Replace:=myReplacementString, Start:=myStartPosition, Count:=myNumberOfReplacements)

    'End Sub
    '++++++++++++++++++++++++++++++++++++++++++++++++

    'https://www.ozgrid.com/forum/forum/help-forums/excel-general/101320-vba-open-files-from-a-list
    'OPEN FILES LOOP FILES FOLDER OPEN AS PER LIST
    'LOOP OPEN & PROCESS FILES AS PER LIST ON SHEET
    'OPEN & PROCESS FILES AS PER LIST ON SHEET RANGE
    'Sub LoopOpenAndProcessFilesAsListok()

        Dim myDir As String
        Dim R As Range
        Dim fn As String
        Dim msg As String
        Dim destwbk As Workbook
        Dim SWBK As Workbook
     
        Dim destsht As Worksheet
        Dim swsht As Worksheet
        Dim mainsht As Worksheet
     
     
        Application.ScreenUpdating = False
        Application.EnableEvents = False
        Application.Calculation = xlCalculationManual
     
        Set destwbk = ActiveWorkbook
        Set mainsht = destwbk.Sheets(1)
        Set destsht = destwbk.Sheets(2)
     
        mainsht.Activate
     
        myDir = ActiveSheet.Range("A2").Value
     
        If Right(myDir, 1) <> "\" Then
            myDir = myDir & "\"
        End If
     
        On Error GoTo skip:
     
        For Each R In ActiveSheet.Range("A8", Range("A" & Rows.Count).End(xlUp))
         
            fn = Dir(myDir & R.Value)
         
                If fn = "" Then
                    msg = msg & vbLf & R.Value
                 
                Else
                 
            With Workbooks.Open(myDir & fn) 'YOU CAN PUT HERE WILD CARD "*" OR OTHER LIKE (& "*")
                                                                                             
                Set SWBK = ActiveWorkbook
                Set swsht = SWBK.Sheets(1)
                     
                        mainsht.Range("D1:P5").Copy
                     
                        swsht.Range("K1").Activate
                                            ActiveSheet.Paste
                     

                                    Application.CutCopyMode = False
                                    ActiveSheet.Range("K1").Select
                                 
                                    End With
                                 
                                    End If
    '++++++++++++++++++++++++++++++++++++++++++++++++
         
      'ADVANCE FILTER ON MULTIPLE CRITERA ,  multi critera , multi_critera & SEPRATE THAT FILE BASIC CODE
    'https://chandoo.org/forum/threads/formula-for-advance-filter-on-multiple-criteria-for-separate-each-filtered-instance-as-new-file.36314/#post-218502
    'ASKED FROM CHIRAG
    'ANSWERED BY NARAYANK991
    'Sub STG_MasterOrdStaMultCriSepFile()

        Dim lrow As Long
        Dim i As Integer
        Dim criteriarows As Long
        Dim inputdatarange As Range
        Dim criteria_range As Range
        Dim rw As Variant
        Dim criteria_header As Range
        Dim crange As Range
        Dim Criteria As New Collection
     
     
        With swsht
        If .AutoFilterMode Then .Cells.AutoFilter
            lrow = .Cells(Rows.Count, 1).End(xlUp).Row
            Set inputdatarange = .Range("A1:I" & lrow)
            criteriarows = .Range("K" & Rows.Count).End(xlUp).Row
            Set criteria_range = .Range("K2:K" & criteriarows).Resize(, 6)
            Set crange = .Range("R1:R2").Resize(, 6)
        End With
     
        On Error GoTo skip
     
        For Each rw In criteria_range.Rows
     
            crange.Cells(2, 1).Resize(, 6) = rw.Value
            inputdatarange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=crange, Unique:=False
         
        If destsht.Range("A1") = "" Then

            swsht.Range("A1:I" & lrow).Copy
                                 
            Else
                               
                swsht.Range("A2:I" & lrow).Copy
                End If


        If Len(msg) Then
            MsgBox "Not found" & msg
        End If
     
     
        destsht.Activate


    If destsht.Range("A1") = "" Then

    destsht.Range("A1").Activate


    Else
    'REMEMBER IF NO DATA FOUND THEN ("a").END METHOD FAIL &
    'ROWS 1 WILL BE OVER WRITTEN THEN SECURED & MUST BE USED ROWS COUNT METHOD AS BELOW

    destsht.Range("A" & Rows.Count).End(xlUp).Offset(1).Activate

    End If

    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

       
                    Application.CutCopyMode = False
                 
        SWBK.Activate
         
            If ActiveSheet.FilterMode Then ActiveSheet.showAllData
                       
             
        Next rw
                         
     
        '++++++++++++++++++++++++++++++++++++++++++++++++
    skip:
    'resume to next rw
    Resume Next
    'Next swbk
    Resume Next
    'End With


    If ActiveSheet.FilterMode Then ActiveSheet.showAllData
            ActiveSheet.AutoFilterMode = False
         
    SWBK.Close SaveChanges:=False

    DoEvents
     
    destwbk.Sheets(1).Activate

    Next R
    End sub
     
    if any data not match with criteria , this code fetch all data of that file that's should not.
    how to modify this code?

    Regards,

    Chirag Raval
  14. Marc L

    Marc L Excel Ninja

    Messages:
    3,891

    Difficult to answer without a workbook attachment
    and which is the part of the code for this issue …​
  15. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir @MarcL,

    on 2nd macro, (Data Fetcher) , At the filter portion, (below) , when criteria range's criteria line, not match with data & advance filter fail to fetch any data
    its take whole database & copy to new sheet.

    There should be if record not match with criteria , nothing can be happen & resume next, that I can not construct this check.

    Code (vb):

    With swsht
        If .AutoFilterMode Then .Cells.AutoFilter
            lrow = .Cells(Rows.Count, 1).End(xlUp).Row
            Set inputdatarange = .Range("A1:I" & lrow)
            criteriarows = .Range("K" & Rows.Count).End(xlUp).Row
            Set criteria_range = .Range("K2:K" & criteriarows).Resize(, 6)
            Set crange = .Range("R1:R2").Resize(, 6)
        End With
     
        On Error GoTo skip
     
        For Each rw In criteria_range.Rows
     
            crange.Cells(2, 1).Resize(, 6) = rw.Value
            inputdatarange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=crange, Unique:=False

     
    Actually this code obtain from this sites, from Mr Narayanak. They help to complete my thread matter.

    please download post not 14' file for reference in below code,

    Their ,(Mr Narayank's) IsInCollection function is not used on multiple criteria sub.
    may be that function construct for only column "V" not for resize 1 to 6,
    (Multiple criteria)

    https://chandoo.org/forum/threads/f...ate-each-filtered-instance-as-new-file.36314/

    hope there are some solution..

    regards,

    Chirag Raval
  16. Marc L

    Marc L Excel Ninja

    Messages:
    3,891
    As the issue comes from using in place an advanced filter
    via its parameter xlFilterInPlace why don't you use xlFilterCopy
    instead as it's a copy operation ?

    Edit : same if InPlace or either Copy, result is empty when no match !
    So what you wrote in post #13 seems weird …
    But question remains : why filter in place instead of copy ?
  17. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sir @Marc L,

    Thanks for your valuable point .
    I think You may want to say if use filter in place,
    Then should use xlfiltercopy , sorry but which I never try to use before.

    You can check yourself in VBA, through step by step F8 ,with my attached 3 source files,
    ,With data fetcher macro, that if 5 columns criteria row , not match with
    Any record with source file, it take whole database from source file & paste on destination
    Sheet.

    Or you can check it in one
    File which you downloaded from my given link.

    I also take steps for criteria's header and source file/ range's header
    Must be same.

    I also check by enter criteria through like we enter formula
    In cell,
    Like under Buy header I put buyer no with
    "=11345" & my 3 files attached as samples for check
    Buyer no 11345 which Feb month file , not match any data with
    11345 & it's take whole database.

    Hope some mistake traped in my setup by your point of view
    Which , till not found by me.

    Hope your co operation.

    Regards,

    Chirag Raval
  18. Marc L

    Marc L Excel Ninja

    Messages:
    3,891
    With my below attachment enter in cell C3 india for example :
    the members list is now filtered on India …

    Then replace india by spain : the list remains empty …
    So when no matches, it can't copy anything !

    Feuil1 is a worksheet filtered in place and
    Feuil2 is a worksheet filtered by copy from Feuil1 …​

    Attached Files:

    Chirag R Raval likes this.
  19. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear Sirs, @NARAYANK991 & @Marc L ,


    Thank you Sir @Marc L , for your simple structure of advance filter example.
    can I apply it on my multiple criteria structure? how can I modify my below code?


    But...Why Below code paste all data of source file if advance filter criteria rows record which not match with source data, ?

    it should not do anything, just need to resume next if not match.


    Code gifted by @NARAYANK991 , for link reference, this threads post no 15.

    Please apply below code to my attached file name 01022017-small...(Feb month) uploaded on this thread's post no 11.



    Code (vb):

    'ADVANCE FILTER ON MULTIPLE CRITERA ,  multi critera , multi_critera & SEPRATE THAT FILE BASIC CODE
    'https://chandoo.org/forum/threads/formula-for-advance-filter-on-multiple-criteria-for-separate-each-filtered-instance-as-new-file.36314/#post-218502
    'ASKED FROM CHIRAG
    'ANSWERED BY MR NARAYANK991
    'Sub STG_MasterOrdStaMultCriSepFile()

        Dim lrow As Long
        Dim i As Integer
        Dim criteriarows As Long
        Dim inputdatarange As Range
        Dim criteria_range As Range
        Dim rw As Variant
        Dim criteria_header As Range
        Dim crange As Range
        Dim Criteria As New Collection
     
     
        With swsht
        If .AutoFilterMode Then .Cells.AutoFilter
            lrow = .Cells(Rows.Count, 1).End(xlUp).Row
            Set inputdatarange = .Range("A1:I" & lrow)
            criteriarows = .Range("K" & Rows.Count).End(xlUp).Row
            Set criteria_range = .Range("K2:K" & criteriarows).Resize(, 6)
            Set crange = .Range("R1:R2").Resize(, 6)
        End With
     
        On Error GoTo skip
     
        For Each rw In criteria_range.Rows
     
            crange.Cells(2, 1).Resize(, 6) = rw.Value
            inputdatarange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=crange, Unique:=False
         
        If destsht.Range("A1") = "" Then

            swsht.Range("A1:I" & lrow).Copy
                                 
            Else
                               
                swsht.Range("A2:I" & lrow).Copy
                End If
        If Len(msg) Then
            MsgBox "Not found" & msg
        End If
         
        destsht.Activate

    If destsht.Range("A1") = "" Then
    destsht.Range("A1").Activate

    Else
    'REMEMBER IF NO DATA FOUND THEN ("a").END METHOD FAIL &
    'ROWS 1 WILL BE OVER WRITTEN THEN SECURED & MUST BE USED ROWS COUNT METHOD AS BELOW

    destsht.Range("A" & Rows.Count).End(xlUp).Offset(1).Activate

    End If

    ActiveCell.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False

       
                    Application.CutCopyMode = False
                 
        SWBK.Activate
         
            If ActiveSheet.FilterMode Then ActiveSheet.showAllData
                 
             
        Next rw
                '++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
    skip:
    'resume to next rw
    Resume Next
    'Next swbk
    Resume Next
    'End With

    If ActiveSheet.FilterMode Then ActiveSheet.showAllData
            ActiveSheet.AutoFilterMode = False
         
    SWBK.Close SaveChanges:=False

    DoEvents
     
    destwbk.Sheets(1).Activate

    Next r

     
    please help..

    Regards,

    Chirag Raval
  20. Marc L

    Marc L Excel Ninja

    Messages:
    3,891
    As any advanced filter is a « multiple criteria structure »
    like you can first see and test with my attachment …
    In a second time create a new advanced flter procedure on your worbook …
  21. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    Dear All,

    This thread resolved now.

    All final work is below for who seek for copy all filtered data from multiple source workbook to current this workbook.

    (1) code 1 for prepare criteria
    Code (vb):

    'READY MADE STRUCTURE
    'INVOICE INFORMATION DATA FETCH FROM FOLDER ALL FOLDER LOOP ALL FILES MULTI CRITERA STRUCTURE


    Sub prepareStructureForCritera()
    With ActiveWorkbook.ActiveSheet
        .Range("D1").FormulaR1C1 = "Customer"
        .Range("E1").FormulaR1C1 = "Inv. Date"
        .Range("F1").FormulaR1C1 = "Inv. Date"
        .Range("G1").FormulaR1C1 = "Sal Doc Ty"
        .Range("H1").FormulaR1C1 = "Material"
        .Range("I1").FormulaR1C1 = "Batch"
        .Range("D2").FormulaR1C1 = ">=0"
        .Range("E2").FormulaR1C1 = "="">=""& DATEVALUE(""01-01-2017"")"
        .Range("F2").FormulaR1C1 = "=""<=""& DATEVALUE(""31-12-2017"")"
        .Range("G2").FormulaR1C1 = "YBKG"
        .Range("H2").FormulaR1C1 = "005384-0008"
        .Range("I2").FormulaR1C1 = "*"
      .Range("D1:I5").Select
        With Selection.Interior
            .Pattern = xlSolid
            .PatternColorIndex = xlAutomatic
            .color = 65535
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        End With
        Cells.EntireColumn.AutoFit
        Range("D1:I5").Select
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        Selection.Borders(xlDiagonalDown).LineStyle = xlNone
        Selection.Borders(xlDiagonalUp).LineStyle = xlNone
        With Selection.Borders(xlEdgeLeft)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeTop)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeBottom)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlEdgeRight)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlMedium
        End With
        With Selection.Borders(xlInsideVertical)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With Selection.Borders(xlInsideHorizontal)
            .LineStyle = xlContinuous
            .ColorIndex = 0
            .TintAndShade = 0
            .Weight = xlThin
        End With
        With ActiveSheet
     
        Range("D1:I1").Select
        Selection.Font.Bold = True
        Range("D1:I5").Select
        Selection.Copy
        Range("K1").Select
        ActiveSheet.Paste
     
          Application.CutCopyMode = False
        Cells.Select
        Cells.EntireColumn.AutoFit
        Range("I1").Select
     
       
        Range("K2:P5").Cells.ClearContents
        Range("K3:P5").Cells.ClearFormats
     
        With ActiveSheet.Range("A1")
        .Font.Bold = True
        .Font.Size = "16"
        End With
     
        Range("A1").Select
        ActiveCell.FormulaR1C1 = _
            "WARNING-PLEASE CHECK OF AUTOMETIC CHANGE PATH? (AT END FULL-SMALL)" & Chr(10) & _
            "FOR BIG OR SMALL DETAIL-DIRECT LINK TO A2" & Chr(10) & _
            "MUST ENTER MONTH'S END DATE AT TO DATE"
        ActiveCell.RowHeight = 62
     
        With ActiveSheet.Range("A5")
     
        .FormulaR1C1 = "MUST BE ENTER MONTH'S END DATE AT TO DATE"
        .HorizontalAlignment = xlCenter
        .BorderAround _
    ColorIndex:=1, Weight:=xlMedium
     
        End With
     
        Range("A2").Value = "D:\SOMEFOLDER\SOMEFOLDER\"
        Range("A4").Value = "YOU CAN SEE RESULT IN NEXT SHEET"
     
        With ActiveSheet.Range("A4")
     
        .Font.Bold = True
        .Font.Size = "16"
     
        Columns.AutoFit
       
    End With
     
        End With
    End Sub
     
    Last edited: May 3, 2018
  22. Chirag R Raval

    Chirag R Raval Member

    Messages:
    588
    (2) Put below uploaded 2 example data files in some folder & give path to it in code.

    Please Change Your Query In Critera Structure After Sudy 2 Datafiles From Which You Want On Filter

    (3) Now code 2 for loop over partial text as list of files mentioned under "A5"
    this list generated automatic by code based on dated un criteria structure.

    THIS CODE HAVE MORE THEN 10,000 CHARECHTERS SO PUT IT IN EXCEL FILE
    PLEASE DOWNLOAD 2ND

    Attached Files:

Share This Page