consolidate or create a new vba code for performing tasks

Below are the steps that i want to perform in a excel file

Step 1: Delete first 6 rows
Step 2: Filter by column A and delete blank rows
Step 3: Based on Column "C" Create a new excel file for uniq values (example if have value as "1" in column C for three rows it have to create new file as "Australia_1" in the drive specified by user or in the same drive where the macro is being run

or if i am not clear on the step 3 if i create a pivot by column c and for each value of the count in need a separate file

to perform above tasks I have gathered some code from various websites

I have about 3 codes taken from different websites

The first ( Sub sbVBS_To_Delete_EntireRow_For_Loop()) macro deletes first 6 rows
The Second one (Sub DeleteRows()) filters Col A and delete blanks
The Third one (parse_data()) copies the data for all the unique values from column C and creates a new sheet
the fourth one (Sub newfile()) create a new work file

I have two questions
1. How can I consolidate all into one code and if possible how can create as an application or UI
2. when creating a new file how can i add a prefix to the file name along with worksheet name (for example every filename starts with "Australia"

Sub sbVBS_To_Delete_EntireRow_For_Loop()
Dim iCntr
For iCntr = 1 To 6 Step 1
Rows(1).EntireRow.Delete
Next
End Sub

Sub DeleteRows()
    With ActiveSheet
        .AutoFilterMode = False 'remove filter
        With .Range("A:Q")
            .AutoFilter field:=1, Criteria1:="="
            On Error Resume Next ' for the case when there is no visible rows
            .Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            On Error GoTo 0
        End With
        .AutoFilterMode = False 'remove filter
    End With
End Sub

Open in new window

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 3
Set ws = Sheets("Customer Ledger Report")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:Q1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate
End Sub

Open in new window

Sub newfile()
MyPath = ThisWorkbook.Path
For Each sht In ThisWorkbook.Sheets
sht.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\" & sht.Name & ".xls"
ActiveWorkbook.Close savechanges:=False

Next sht

End Sub

Open in new window

Microsoft ExcelVisual Basic ClassicVBA

Last Comment

Ryan Chong

8/22/2022 - Mon

Ryan Chong

9/6/2016

just some quick replies...

>>1. How can I consolidate all into one code and if possible how can create as an application or UI
You can create a userform in Excel.

Userform
http://www.excel-easy.com/vba/userform.html

>>2. when creating a new file how can i add a prefix to the file name along with worksheet name (for example every filename starts with "Australia"

amend this line in Sub newfile() from:

Filename:=MyPath & "\" & sht.Name & ".xls"

Open in new window

to:

Filename:=MyPath & "\Australia_" & sht.Name & ".xls"

Open in new window

Nirvana

9/7/2016

ASKER

Thank you Ryan. I have consolidated the code as below. I have couple of questions.

1. How can I create button for macro as part of the tool bar?
2. As part of the file I have do a vlookup from different file and based on column C and add it as part of the file name how can I achieve that?

Sub sbVBS_To_Delete_EntireRow_For_Loop()
Dim iCntr
For iCntr = 1 To 6 Step 1
Rows(1).EntireRow.Delete
Next
    With ActiveSheet
        .AutoFilterMode = False 'remove filter
        With .Range("A:Q")
            .AutoFilter field:=1, Criteria1:="="
            On Error Resume Next ' for the case when there is no visible rows
            .Resize(.Rows.Count - 1).Offset(1, 0).SpecialCells(xlCellTypeVisible).EntireRow.Delete
            On Error GoTo 0
        End With
        .AutoFilterMode = False 'remove filter
    End With

Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer
vcol = 3
Set ws = Sheets("Customer Ledger Report")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:Q1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
Sheets(myarr(i) & "").Columns.AutoFit
Next
ws.AutoFilterMode = False
ws.Activate

MyPath = ThisWorkbook.Path
For Each sht In ThisWorkbook.Sheets
sht.Copy
ActiveSheet.Cells.Copy
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues
ActiveSheet.Cells.PasteSpecial Paste:=xlPasteFormats
ActiveWorkbook.SaveAs _
Filename:=MyPath & "\Open Post List-Bring Cargo AS_" & sht.Name & ".xls"
ActiveWorkbook.Close savechanges:=False

Next sht

End Sub

Open in new window

ASKER CERTIFIED SOLUTION

Ryan Chong

9/7/2016

THIS SOLUTION ONLY AVAILABLE TO MEMBERS.

View this solution by signing up for a free trial.

Members can start a 7-Day free trial and enjoy unlimited access to the platform.

See Pricing Options

Start Free Trial

GET A PERSONALIZED SOLUTION

Ask your own question & get feedback from real experts

Find out why thousands trust the EE community with their toughest problems.

Nirvana

9/7/2016

ASKER

Ryan,

I have couple of questions.

1. How can I create button for macro as part of the tool bar?
2. As part of the file I have do a vlookup from different file and based on column C and add it as part of the file name how can I achieve that?

Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!

James Murphy

Ryan Chong

9/7/2016

>>1. How can I create button for macro as part of the tool bar?
do you mean to add the command button from the toolbar option?

>>2. As part of the file I have do a vlookup from different file and based on column C and add it as part of the file name how can I achieve that?
in macro you can use : Application.WorksheetFunction.VLookup for vlookup function.