Advanced filtering of data into other sheet and copying the same sheet into a new workbook

[spvsr999]

Hello ..!!

This is my 3rd thread with Mr.Excel and my journey here is making me visualize what all can I automate using VBA and becoming successful with smaller macros for now. Thanks to everyone who is making my journey here fruitful ..!!

So I am here with a request for macro that I need in the activity I am working on .. I need multiple things to be done at a single click.

Don't know if this is a possible criteria or not!!

Hope someone can help me with this ..!!

Thanks in advance

Scenario -

I have a sheet named "Tracking tool" in a workbook. It has a whole set of data 5000+ lines. There is a column "Progress Status" from which I would like to filter data and paste it into few another sheets (Formats should remain the same from "Tracking tool" sheet and All rows & column width should be adjusted accordingly)

The column "Progress status" has "PENDING", "IN PROGRESS", "COLLECTED", "SUBMITTED", "COMPLETED", "NOT APPLICABLE", "REJECTED" as the unique list.

I also have many other sheets but notable among them are "DASHBOARD" "Current", "Not Applicable", "Completed", "Rejected" "Data Validation".

VBA REQUEST.

1) In the worksheets "Current", "Not Applicable", "Completed", "Rejected" DELETE the old content from row A4 (A1-A3 should remain untouched).
And then
Copy all the rows & columns that fall under criteria "PENDING", "IN PROGRESS", "COLLECTED", "SUBMITTED" in "Progress status" to "Current" Worksheet.
Copy all the rows & columns that fall under criteria "NOT APPLICABLE" in "Progress status" to "Not Applicable" worksheet.
Copy all the rows & columns that fall under criteria "COMPLETED" in "Progress status" to "Completed" worksheet.
Copy all the rows & columns that fall under criteria "REJECTED" in "Progress status" to "Rejected" worksheet.

A4 should have Headings that should also get deleted and copied each time I run the macro (Autofit most important)

2) Once all the above rows and columns are copied, I would like to extract the sheets "DASHBOARD" "Current", "Not Applicable", "Completed", "Rejected" into a new workbook with a name mentioned in cells A2 of "Data Validation" worksheet and save it in path mentioned in cell A3 of "Data Validation" sheet.

I tried to record a macro and edit the same but failed in it.

Hope someone can help me sooner with this macro !!

Thank you

 

[mse330]

Hi spvsr999,

Try below code ...

Sub test()

Dim ws As Worksheet, a, i&, Lc&
a = Array([{"Progress status";"ENDING";"IN PROGRESS";"COLLECTED";"SUBMITTED"}], [{"Progress status";"NOT APPLICABLE"}], [{"Progress status";"COMPLETED"}], [{"Progress status";"REJECTED"}])

i = 0
For Each ws In Sheets(Array("CURRENT", "NOT APPLICABLE", "COMPLETED", "REJECTED"))
   ws.Range("A4").CurrentRegion.Offset(3).Delete
   With Sheets("Tracking tool").[A1].CurrentRegion
      .Rows(1).Copy ws.[A4] 'Assuming header is in row 1 in sheet Tracking tool
      Lc = .Columns.Count + 5
      .Cells(1, Lc).Resize(UBound(a(i))) = a(i)
      .AdvancedFilter 2, .Cells(1, Lc).CurrentRegion, ws.[A4].Resize(, .Columns.Count)
      .Cells(1, Lc).CurrentRegion.Clear
   End With
   ws.[A4].CurrentRegion.Columns.AutoFit
   i = i + 1
Next

End Sub

 

[spvsr999]

Hi spvsr999,

Try below code ...

Sub test()

Dim ws As Worksheet, a, i&, Lc&
a = Array([{"Progress status";"ENDING";"IN PROGRESS";"COLLECTED";"SUBMITTED"}], [{"Progress status";"NOT APPLICABLE"}], [{"Progress status";"COMPLETED"}], [{"Progress status";"REJECTED"}])

i = 0
For Each ws In Sheets(Array("CURRENT", "NOT APPLICABLE", "COMPLETED", "REJECTED"))
   ws.Range("A4").CurrentRegion.Offset(3).Delete
   With Sheets("Tracking tool").[A1].CurrentRegion
      .Rows(1).Copy ws.[A4] 'Assuming header is in row 1 in sheet Tracking tool
      Lc = .Columns.Count + 5
      .Cells(1, Lc).Resize(UBound(a(i))) = a(i)
      .AdvancedFilter 2, .Cells(1, Lc).CurrentRegion, ws.[A4].Resize(, .Columns.Count)
      .Cells(1, Lc).CurrentRegion.Clear
   End With
   ws.[A4].CurrentRegion.Columns.AutoFit
   i = i + 1
Next

End Sub

Hi @mse330,

The code is working the same way I expected it to work !!

However, can you tell me where to tweak the code as the headers in sheet "Tracking tool" start from the 13th row!

Also, any idea about the second part of my request i.e.,

Once the above macro runs successfully, I would like to extract a copy of the sheets "DASHBOARD" "Current", "Not Applicable", "Completed", "Rejected" into a new workbook with a name mentioned in cells A2 of "Data Validation" sheet and save it in the path mentioned in cell A3 of "Data Validation" sheet.

But Thanks a ton for your reply... I thought my thread went unnoticed !!

 

[spvsr999]

Hi,

In the first part code, I am still stuck on how to change from 1 to 13 row.

For the second half of my VBA request, I have looked at many codes and came up with the code below.

However, if I am running the file for a new date first time it works well. If I want to re-run the macro for the same date it is throwing an error at "MkDir Filename"

Could anyone help me on tweaking this to make sure it runs always without any error.

Sub SplitWorkbook()

Dim FileExtStr As String
Dim xWs As Worksheet
Dim xWb As Workbook
Dim xNWb As Workbook
Dim Path As String
Dim FileName As String

Application.ScreenUpdating = False

Set xWb = Application.ThisWorkbook
 
Path = "C:\Users\psreekanth\Desktop\Adhoc - Tracking tool\3 - Tracking tool Trial"
FileName = ThisWorkbook.Sheets("Data Validation").Range("A2").Value

If Val(Application.Version) < 12 Then
    FileExtStr = ".xls": FileFormatNum = -4143
Else
    Select Case xWb.FileFormat
        Case 51:
            FileExtStr = ".xlsx": FileFormatNum = 51
        Case 52:
            If Application.ActiveWorkbook.HasVBProject Then
                FileExtStr = ".xlsm": FileFormatNum = 52
            Else
                FileExtStr = ".xlsx": FileFormatNum = 51
            End If
        Case 56:
            FileExtStr = ".xls": FileFormatNum = 56
        Case Else:
            FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
End If
 
MkDir FileName
 
    Worksheets(Array("DASHBOARD", "CURRENT", "NOT APPLICABLE", "COMPLETED", "REJECTED")).Copy
    With ActiveSheet.UsedRange
        .Value = .Value
    End With

    xFile = Path & "\" & FileName & FileExtStr
    Set xNWb = Application.Workbooks.Item(Application.Workbooks.Count)
    xNWb.SaveAs xFile, FileFormat:=FileFormatNum
    xNWb.Close False, xFile

    xWb.Activate

    MsgBox "Status of IPF Tracking tool saved in the folder. "
    Application.ScreenUpdating = True

End Sub

Hoping for some help ASAP. Thanks in advance.

 

[mse330]

Hi spvsr999,

You can change it to the 13th row by changing [A1] With [A13] in the following line With Sheets("Tracking tool").[A13].CurrentRegion. Note that this is using CurrentRegion so if you have data in row #12 it will not work correctly so we need to amend.

Regarding your 2nd code, what value do you have in Sheets("Data Validation").Range("A2").Value ? I think it is throwing an error because you're trying to save another file in the same name which already exists. If you have today's date, you can add the time as well to the file name, something like below

Filename = Format(Now, "dd-mmm-yyyy hh_mm_ss")

 

[spvsr999]

Hi spvsr999,

You can change it to the 13th row by changing [A1] With [A13] in the following line With Sheets("Tracking tool").[A13].CurrentRegion. Note that this is using CurrentRegion so if you have data in row #12 it will not work correctly so we need to amend.

Regarding your 2nd code, what value do you have in Sheets("Data Validation").Range("A2").Value ? I think it is throwing an error because you're trying to save another file in the same name which already exists. If you have today's date, you can add the time as well to the file name, something like below

Filename = Format(Now, "dd-mmm-yyyy hh_mm_ss")

Hi @mse330,

I will try the change in the first code and update you the findings.

Regarding code#2, Yes, Cell A2 has File name mentioned in it ...!!

Can we tweak this code in such a way that it replaces in case there is a file already with same name (date).

 

[mse330]

OK, try to add the below line which will basically will check if the file exists it deletes it

FileName = ThisWorkbook.Sheets("Data Validation").Range("A2").Value
If Dir(FileName) <> "" Then Kill FileName

 

[spvsr999]

OK, try to add the below line which will basically will check if the file exists it deletes it

FileName = ThisWorkbook.Sheets("Data Validation").Range("A2").Value
If Dir(FileName) <> "" Then Kill FileName

With the tweak mentioned for Code#1, that is working perfectly fine and just like how I wanted it to ... Thanks a lot for it.

However for Code#2, after placing an additional line to KILL, I am still receiving the error.

"Run-time error '75'
Path/File access error"

The error is displayed near the line "MkDir FileName".

 

[spvsr999]

I would like to thank @mse330 for all the time spent helping me with my codes.

Below are the final codes that I used in achieving my End result.

Code #1 : Copy Paste Data based on a column into different sheets

Sub UpdateSheets()

Dim ws As Worksheet, a, i&, Lc&
a = Array([{"Progress Status";"PENDING";"IN PROGRESS";"COLLECTED";"SUBMITTED"}], [{"Progress Status";"NOT APPLICABLE"}], [{"Progress Status";"COMPLETED"}], [{"Progress Status";"REJECTED"}])

i = 0
For Each ws In Sheets(Array("Current", "Not Applicable", "Completed", "Rejected"))
   ws.Range("A4").CurrentRegion.Offset(3).Delete
   With Sheets("Tracking tool").[A1].CurrentRegion
      .Rows(1).Copy ws.[A4] 'Assuming header is in row 1 in sheet Tracking tool
      Lc = .Columns.Count + 5
      .Cells(1, Lc).Resize(UBound(a(i))) = a(i)
      .AdvancedFilter 2, .Cells(1, Lc).CurrentRegion, ws.[A4].Resize(, .Columns.Count)
      .Cells(1, Lc).CurrentRegion.Clear
   End With
   ws.[A4].CurrentRegion.Columns.AutoFit
   i = i + 1
Next

End Sub

Code #2 : Extract specific sheets from Main file into a new workbook and save the same based on path and name specified in a cell

Sub BuildReport()

Dim wb As Workbook
Dim MyFileName As String
Dim MyPath As String

Application.ScreenUpdating = False
Application.DisplayAlerts = False

MyFileName = ThisWorkbook.Sheets("DataValidation").Range("C5").Value & ".xlsx"
MyPath = ThisWorkbook.Sheets("DataValidation").Range("C3").Value & "\"

ThisWorkbook.Sheets(Array("Summary", "Current", "Not Applicable", "Completed", "Rejected")).Copy

ActiveWorkbook.SaveAs Filename:=MyPath & MyFileName, FileFormat:=51

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Thank you

 

[mse330]

Glad I was able to help & thanks for the feedback Enjoy coding