VBA to filter data, create folder and save file

[Mahesh Babu]

Hello Experts,

I need help on the below

Lets say there are 2 different workbooks :

1 is Raw data workbook with only 1 tab or worksheet called Main Data

1 more workbook where i have or want the code and has only 1 worksheet named Mail Info



Requirement 1 :

In Mail Info workbook Column A ( A2:A50) i have a list of names like Bob, Jack, John, Sibu etc and Cell C7 has a drop down list with reference to column A (A2:A50)



In Raw data file, say i have columns Plan A, Plan B, Email, Plan C, Notes etc., Column Email has different names ( Bob, Jack, John etc)



In Mail Info file, Cell value C7 says Bob, then data related to Bob in the Raw data should be filtered along with formatting (as few of the cells will be colored) and should create a new folder called Bob ( with value in cell C7) and save as a new workbook ( raw data file has only 1 worksheet/tab) in that folder. If folder already exists only file should be saved in the respective folder.



Requirement 2:



In Mail Info file, cell value C7 says ALL, then what ever unique names available under Column Email of the Raw data file ( say there are 10 unique names) data to be filtered for all the unique names accordingly and 10 unique files and folders to created and saved accordingly.

Save as each file or workbook with unique name given under email column

I tried to put requirements as clearer as i can.

Apologies for not able to share the sample file.

Thank you so much for the support.

 

[vletm]

Mahesh Babu
Hint / truth:
Without real sample file with sample data ... Your'll have to wait and wait ... and wait.

It would be possible to create code for above,
but ... without possible to test it, it would need a lot of time.
If You do not have eg time to create a sample file, then how others could have time to guess details of Your files.

 

[Mahesh Babu]

I have 2 workbooks.

1 is "Raw Data" and another one "Mail Info"

I'm looking for a VB code with the below requirements:

1. In "Mail Info" workbook, columns A (A2: A20) has a list of names and Cell "C7" has drop down list with reference to "A2:A20"

2. If Cell “C7” says value as “Chandoo”, then data in “Raw Data” workbook should filter by “Chandoo” (can be found in column name “Email”) and create a new folder called “Chandoo” and save the file as “Chandoo + current date + current time).xlsx in a specific path. (“C:\\Desktop\Files\Chandoo\Chandoo_8/18/2020_2:23 PM.xlsx). If folder already exists only the excel workbook should get saved

3. If Cell “C7” says “ALL”, then data in “Raw Data” workbook should filter by all the names given in column A (A2:A20). The above step should be repeated for each unique name.

***The below point is not mandate, would be helpful if can be done.***

4. If column A (A2:A20) has names like ‘Chandoo’, ‘Mahesh’, ‘John’ etc., however “Raw data” has unique names like ‘Chandoo’, ‘Mahesh’, ‘John’, ‘Bob’, which is missing in the list, then folder and file creation should be done for ‘Bob’ as well and the name to be added to column A (A2:A20)

Note: Here, I’m trying to split the raw data file into each individual files and save in the respective folders.

 

[Luke M]

Cross-post link: https://www.mrexcel.com/board/threa...te-folder-save-as-different-workbook.1142935/

 

[Mahesh Babu]

Reason for posting here again
in the other forum i’m unable to attch the sample files also i dont see any response.

Requeest you to help on the above requirements

 

[vletm]

Mahesh Babu
You should reread Forum Rules

Site Rules - New Users - Please Read

Hi all, Welcome to the Chandoo.org Forums. Posting Rules & Etiquette The Chandoo.org Forums is a collaborative and happy place to learn and expand your Excel knowledge. The Chandoo.org Forums consist of several Sub-Forums based on the type of question/area of Excel you are interested in...

chandoo.org

There are eg written as below:

• Cross-Posting. Generally, it is considered poor practice to cross post. That is to post the same question on several forums in the hope of getting a response quicker.
• If you do cross-post, please put that in your post.
• Also if you have cross-posted and get an Solution elsewhere, have the courtesy of posting the Solution here so other readers can learn from the answer also, as well as stopping people wasting their time on your answered question.

 

[Mahesh Babu]

Sure. Agree with the points
In the other forum i got a response stating never worked on this scenario and unable to help, then only i posted here
Even i tried deleting the post in the other forum
Unfortunately it is not allowing me to do i am able to modify and also some other limitations like unable to attach sample files over there. Without sample files it very difficult to get a response also as mentioned above
As my file cannot be shared , hence i did nt attach sample files in the 1st instance. As without sample files it will be difficult hence created a sample file and attched again.

Appreciate your help/support

 

[RDAngelo]

Let's see if this can work for you... doesn't work on ALL as yet.

Option Explicit

Sub Filter_and_Copy()
    Dim wb As Workbook, wbk As Workbook
    Dim sCriteria As String, sFile As String
    Dim rg As Range

    On Error Resume Next
    Set wb = Workbooks("Raw Data.xlsx")
    On Error GoTo 0
    If wb Is Nothing Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\Raw Data.xlsx")
    
    With ThisWorkbook.Sheets("Mail Info")
        sCriteria = .Cells(7, 3).Value
        If sCriteria <> "All" Then
            If Dir(ThisWorkbook.Path & "\" & sCriteria, vbDirectory) = vbNullString Then
                MkDir ThisWorkbook.Path & "\" & sCriteria
            End If
            Set wbk = Workbooks.Add(xlWBATWorksheet)
            sFile = ThisWorkbook.Path & "\" & sCriteria & "\" & sCriteria & Format(Now(), "_m-d-yyyy_h mm am/pm") & ".xlsx"
            wbk.SaveAs sFile
            
            Set rg = wb.Sheets(1).Cells(1, 1).CurrentRegion
            rg.AutoFilter field:=3, Criteria1:=sCriteria
            rg.SpecialCells(xlCellTypeVisible).Copy wbk.Worksheets(1).Cells(1, 1)
            rg.AutoFilter
        End If
    End With
End Sub

 

[Mahesh Babu]

Hi, i am getting the error as attached
However folder is getting created

 

[RDAngelo]

Can't view your images... Try the attached file

 

[Mahesh Babu]

Here is the error message

 

[RDAngelo]

Do you get the same error when running the code on the original Raw Data file? If so, is the variable sFile string longer than allowed?

 

[Mahesh Babu]

Even i tried saving code file on a smaller path and the same error
Can we give directly give the path in the code ? I mean like C:\Desktop\Mydocuments\.....

 

[RDAngelo]

OK, try this...

Option Explicit

Sub Filter_and_Copy()
    Dim wb As Workbook, wbk As Workbook
    Dim sCriteria As String, sFile As String
    Dim rg As Range
    
    Const sPath As String = "C:\Desktop\Mydocuments"  '''change as needed

    On Error Resume Next
    Set wb = Workbooks("Raw Data.xlsx")
    On Error GoTo 0
    If wb Is Nothing Then Set wb = Workbooks.Open(sPath & "\Raw Data.xlsx")
    
    With ThisWorkbook.Sheets("Mail Info")
        sCriteria = .Cells(7, 3).Value
        If sCriteria <> "All" Then
            If Dir(sPath & "\" & sCriteria, vbDirectory) = vbNullString Then
                MkDir sPath & "\" & sCriteria
            End If
            Set wbk = Workbooks.Add(xlWBATWorksheet)
            sFile = sPath & "\" & sCriteria & "\" & sCriteria & Format(Now(), "_m-d-yyyy_h mm am/pm") & ".xlsx"
            wbk.SaveAs sFile
            
            Set rg = wb.Sheets(1).Cells(1, 1).CurrentRegion
            rg.AutoFilter field:=3, Criteria1:=sCriteria
            rg.SpecialCells(xlCellTypeVisible).Copy wbk.Worksheets(1).Cells(1, 1)
            rg.AutoFilter
        End If
    End With
End Sub

 

[Mahesh Babu]

Thank you very much. Both the codes working now

Finally able to resolve the error

Near file name in the code, instead of am/pm, by mistake i typed as am//pm hence it is leading to special character.


Appreciate your help again . When ever you get some time please help me on the “ALL” criteria as well.

 

[RDAngelo]

OK. Later today,,,, maybe.

 

[RDAngelo]

Try this...

Sub Filter_and_Copy()
    Dim wb As Workbook, wbk As Workbook
    Dim sCriteria As String, sFile As String
    Dim rg As Range, e As Variant, ar As Variant
    Dim i As Long

    On Error Resume Next
    Set wb = Workbooks("Raw Data.xlsx")
    On Error GoTo 0
    If wb Is Nothing Then Set wb = Workbooks.Open(ThisWorkbook.Path & "\Raw Data.xlsx")
    
    With ThisWorkbook.Sheets("Mail Info")
        sCriteria = .Cells(7, 3).Value
        If sCriteria <> "ALL" Then
            If Dir(ThisWorkbook.Path & "\" & sCriteria, vbDirectory) = vbNullString Then
                MkDir ThisWorkbook.Path & "\" & sCriteria
            End If
            Set wbk = Workbooks.Add(xlWBATWorksheet)
            sFile = ThisWorkbook.Path & "\" & sCriteria & "\" & sCriteria & Format(Now(), "_m-d-yyyy_h mm am/pm") & ".xlsx"
            wbk.SaveAs sFile
            Set rg = wb.Sheets(1).Cells(1, 1).CurrentRegion
            rg.AutoFilter field:=3, Criteria1:=sCriteria
            rg.SpecialCells(xlCellTypeVisible).Copy wbk.Worksheets(1).Cells(1, 1)
            rg.AutoFilter
        Else
            With CreateObject("Scripting.Dictionary")
                Set rg = wb.Sheets(1).Cells(1, 1).CurrentRegion
                For Each e In Application.Index(rg.Columns(3).Value, 0, 0)
                    .Item(e) = Empty
                Next
                ar = .keys
            End With
            For i = 1 To UBound(ar)
                sCriteria = ar(i)
                If Dir(ThisWorkbook.Path & "\" & sCriteria, vbDirectory) = vbNullString Then
                    MkDir ThisWorkbook.Path & "\" & sCriteria
                End If
                Set wbk = Workbooks.Add(xlWBATWorksheet)
                sFile = ThisWorkbook.Path & "\" & sCriteria & "\" & sCriteria & Format(Now(), "_m-d-yyyy_h mm am/pm") & ".xlsx"
                wbk.SaveAs sFile
                rg.AutoFilter field:=3, Criteria1:=sCriteria
                rg.SpecialCells(xlCellTypeVisible).Copy wbk.Worksheets(1).Cells(1, 1)
                rg.AutoFilter
            Next i
        End If
    End With
End Sub

 

[Mahesh Babu]

Thanks for the code. its working fine