Filter Specific Column of Selected files to Master File

[SARAN89]

Hi,

I am using the below VBA Code to filter some specific column (Source file- Active Workbook) and paste in new work book

I need to do this activity for many files. can someone help to modify the code as below.

I need to select multiple files instead of active workbook, then one be one all files to be copied and pasted in new work book.

Example if i select 5 excel files, (All in same folder only) first excel file to be copied and pasted in new workbook (as per sample vba code) and then the new workbook to be saved as main file.
then the second excel file (out of 5) to be copied and pasted in last row of main file.

Currently i am opening one by one and running the macro. Macro is working fine, however instead opening one by one and running the code, i am seeking some one help to modify the code instead of active workbook to selection of excel files.

Kindly help to modify the above code.

Sub Dates()

Dim wb As Workbook: Set wb = ActiveWorkbook
Dim a: a = ActiveSheet.Range(Cells(6, 1), Cells(6, ActiveSheet.UsedRange.Columns.Count))
With ActiveSheet.Range("C1:C" & ActiveSheet.UsedRange.Rows.Count)
.Value = Evaluate(Replace("if(isnumber(@),@)", "@", .Address))
.Parent.UsedRange.AutoFilter 3, "<>False"
.Parent.UsedRange.SpecialCells(12).Copy
End With

Workbooks.Add
[A1].PasteSpecial xlPasteAll
[A1].Resize(, UBound(a, 2)) = a

Application.DisplayAlerts = False
wb.Close False
Application.DisplayAlerts = True

End Sub

[dangelor]

Possibly...

Sub OpenFiles()
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Dim sFiles As Variant, i As Long, wb As Workbook
    sFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
    For i = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(i), ReadOnly:=True)
        
        'do stuff with workbook here
        
        wb.Close
    Next i
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

[SARAN89]

The code is selecting excel files, but can you help me how to link your code with above my code.

[dangelor]

Sub OpenFiles()
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Dim sFiles As Variant, i As Long, wb As Workbook
    sFiles = Application.GetOpenFilename(FileFilter:="Excel Files (*.xls*), *.xls*", MultiSelect:=True)
    For i = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(i), ReadOnly:=True)
        
        'do stuff with workbook here
        Dim a: a = ActiveSheet.Range(Cells(6, 1), Cells(6, ActiveSheet.UsedRange.Columns.Count))
        With ActiveSheet.Range("C1:C" & ActiveSheet.UsedRange.Rows.Count)
            .Value = Evaluate(Replace("if(isnumber(@),@)", "@", .Address))
            .Parent.UsedRange.AutoFilter 3, "<>False"
            .Parent.UsedRange.SpecialCells(12).Copy
        End With
        
        Workbooks.Add
        [A1].PasteSpecial xlPasteAll
        [A1].Resize(, UBound(a, 2)) = a
        
        wb.Close
    Next i
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

[SARAN89]

Hi dangelor.

Thanks for your code. while running the code its opening the selected excel files. but copy and pasting in new sheet not happening.

"Workbooks.Add" kindly make this file as master file and then one by one pasted in this workbook.

[dangelor]

In this bit of code:

Workbooks.Add
[A1].PasteSpecial xlPasteAll
[A1].Resize(, UBound(a, 2)) = a

you are creating a new workbook for every file, and you are pasting something into Range ("A1"), and then immediately overwriting it with the contents of the variable a.
What is it you are trying to accomplish? (Sample workbooks would be helpful to finding a solution)

[SARAN89]

Hi let me explain in detail for the the existing code
The existing code is not for multiple files from one Excel CSV workbook header starting from row 6, on row 6 column C filtering only dates rows (excluding other than date rows)then copying filtered data to new workbook starting from row A1

Currently I am trying to change the above code as below

The existing code I am doing for one csv file, in new code I need to select multiple csv files, each files to be copied (filtering columnC6 with only dates as per existing code) then to be pasted in one workbook. Means output should be single file, each file one by one copied and pasted in one workbook. We can give fixed name for this workbook as master file

[dangelor]

Try this version...

Sub OpenFiles_and_CopyData()
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Dim wbM As Workbook, wsM As Worksheet, lRowM As Long
    Dim wb As Workbook, ws As Worksheet
    Dim lCol As Long, lRow As Long
    Dim sFiles As Variant, i As Long
    
    'create Master workbook
    Set wbM = Workbooks.Add
    wbM.SaveAs "Master.xlsx", 51
    Set wsM = wbM.Worksheets(1)
    
    'cycle through files
    sFiles = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
    For i = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(i), ReadOnly:=True)
        Set ws = wb.ActiveSheet
        
        'copy headers to worksheet in Master file
        lCol = ws.Cells(6, ws.Columns.count).End(xlToLeft).Column
        ws.Range(ws.Cells(6, 1), ws.Cells(6, lCol)).Copy wsM.Cells(1, 1)
        
        'copy filtered rows to worksheet in Master file
        lRow = ws.Cells(ws.Rows.count, 3).End(xlUp).Row
        With ws.Range("C1:C" & lRow)
            .Value = Evaluate(Replace("if(isnumber(@),@)", "@", .Address))
            .Parent.UsedRange.AutoFilter 3, "<>False"
            lRowM = wsM.Cells(wsM.Rows.count, 1).End(xlUp).Row + 1
            .Parent.UsedRange.SpecialCells(12).Copy wsM.Cells(lRowM, 1)
        End With
        wb.Close
    Next i
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

[SARAN89]

Hi dangelor

Thank you so much. code is working as expected. only one issue is that, its copying other row if its having value. though column C is blank.

[SARAN89]

Hi Dangelor.

I have attached sample excel file for your reference. Refer Cell AH24 & A2 ,though column C is blank its coming in Output
C2 also coming in output though its not a "date row". Kindly help to fix this .

[dangelor]

Place this code in a standard module in the Master workbook.

Sub OpenFiles_and_CopyData()
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Dim wbM As Workbook, wsM As Worksheet, lRowM As Long
    Dim wb As Workbook, ws As Worksheet
    Dim lCol As Long, lRow As Long
    Dim sFiles As Variant, i As Long
    
    Set wsM = ThisWorkbook.Worksheets(1)
    sFiles = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
    For i = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(i), ReadOnly:=True)
        Set ws = wb.ActiveSheet
        lCol = ws.Cells(6, ws.Columns.Count).End(xlToLeft).Column
        ws.Range(ws.Cells(6, 1), ws.Cells(6, lCol)).Copy wsM.Cells(1, 1)
        lRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
        With ws.Range("C6:C" & lRow)
            .Value = Evaluate(Replace("if(isnumber(@),@)", "@", .Address))
            .Parent.UsedRange.Offset(5).AutoFilter 3, "<>False"
            lRowM = wsM.Cells(wsM.Rows.Count, 1).End(xlUp).Row + 1
            .Parent.UsedRange.Offset(6).SpecialCells(12).Copy wsM.Cells(lRowM, 1)
        End With
        wb.Close False
    Next i
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

[SARAN89]

Hi Refer the output file (Master Latest) Row AH23
Though no data on Column C its its appearing in output file.
Kindly help to fix this.

And instead of "standard module in the Master workbook" is it possible to run the code from "Personal Macro workbook" (Earlier Code Worked)

[dangelor]

Try this version...

Sub OpenFiles_and_CopyData4()
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Dim wbM As Workbook, wsM As Worksheet, lRowM As Long
    Dim wb As Workbook, ws As Worksheet
    Dim lCol As Long, lRow As Long
    Dim sFiles As Variant, i As Long
    
    Set wbM = Workbooks.Add
    wbM.SaveAs "Master.xlsx", 51
    Set wsM = wbM.Worksheets(1)
    
    sFiles = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
    For i = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(i), ReadOnly:=True)
        Set ws = wb.ActiveSheet
        lCol = ws.Cells(6, ws.Columns.Count).End(xlToLeft).Column
        ws.Range(ws.Cells(6, 1), ws.Cells(6, lCol)).Copy wsM.Cells(1, 1)
        lRow = ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
        With ws.Range("C6:C" & lRow)
            .Value = Evaluate(Replace("if(isnumber(@),@)", "@", .Address))
            .Parent.UsedRange.Offset(6).AutoFilter 3, "<>False"
            lRowM = wsM.Cells(wsM.Rows.Count, 1).End(xlUp).Row + 1
            .Parent.UsedRange.Offset(6).Resize(.Parent.UsedRange.Rows.Count - 7).SpecialCells(12).Copy wsM.Cells(lRowM, 1)
        End With
        wb.Close False
    Next i
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

[SARAN89]

Thanks for your code. Still other rows data is appearing in out put file, though no date in column "C".
Attached Sample file Refer AG 36 and AH36

out put File Refer AG23 and AH23 marked in yellow colour. Kindly help.

[dangelor]

The latest csv file has rows that were not in the previous versions. Will your working csv files also have the added rows? If so, the autofilter section of the code will need to be revamped.

[SARAN89]

Yes I shared sample file however working file having added rows. It's having data in other columns excluding column C. Please help to revamp the code.

[dangelor]

I'll try to get something before the end of today

[dangelor]

One last try...

Sub OpenFiles_and_CopyData5()
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
    End With
    
    Dim wbM As Workbook, wsM As Worksheet, lRowM As Long
    Dim wb As Workbook, ws As Worksheet
    Dim lCol As Long, lRow As Long, rg As Range
    Dim sFiles As Variant, i As Long
    
    Set wbM = Workbooks.Add
    wbM.SaveAs "Master.xlsx", 51
    Set wsM = wbM.Worksheets(1)
    
    sFiles = Application.GetOpenFilename(FileFilter:="CSV Files (*.csv), *.csv", MultiSelect:=True)
    For i = LBound(sFiles) To UBound(sFiles)
        Set wb = Workbooks.Open(sFiles(i), ReadOnly:=True)
        Set ws = wb.ActiveSheet
        lRow = ws.Cells(1, 3).End(xlDown).Row
        ws.Range("C6:C" & lRow).Value = Evaluate(Replace("if(isnumber(@),@)", "@", ws.Range("C6:C" & lRow).Address))
        lCol = ws.Cells(6, 1).End(xlToRight).Column
        ws.Range(ws.Cells(6, 1), ws.Cells(6, lCol)).Copy wsM.Cells(1, 1)
        lRowM = wsM.Cells(wsM.Rows.count, 1).End(xlUp).Row + 1
        Set rg = ws.Range(Cells(1, 1), Cells(lRow, lCol))
        Set rg = rg.Offset(6).Resize(rg.Rows.count - 6)
        With rg
            .AutoFilter 3, "<>False"
            .SpecialCells(12).Copy wsM.Cells(lRowM, 1)
        End With
        wb.Close False
    Next i
    
    With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

[nankw83]

@dangelor … I have encountered similar issue when I provided the first part of the code for a previous thread request. The issue is the OP CSV files don't have consistency in all columns. i.e. You're checking last row based on column C whereas if you refer back to the original code I have lookup the last row based on the used range of the sheet to ensure while filtering I capture all rows with data

@SARAN89, try to change the below line based on @dangelor code in post # 18 & see if that solves your issue

lRow = ws.Cells(1, 3).End(xlDown).Row 'Try to replace this with the below line

lRow = ws.UsedRange.Rows.Count

[SARAN89]

Hi dangelor Code is working fine after replacing "lRow = ws.Cells(1, 3).End(xlDown).Row " with lRow = ws.UsedRange.Rows.Count suggested by Nankw83. Thank you so much for your help.

[dangelor]

Glad I was able to somewhat help.