Solved

consolidate or create a new vba code for performing tasks

Posted on 2016-09-06
5
69 Views
Last Modified: 2016-09-07
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

0
Comment
Question by:Nirvana
  • 3
  • 2
5 Comments
 
LVL 51

Expert Comment

by:Ryan Chong
ID: 41787198
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

?
1
 

Author Comment

by:Nirvana
ID: 41787348
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

0
 
LVL 51

Accepted Solution

by:
Ryan Chong earned 500 total points
ID: 41787390
>>if not the user form how can I consolidate all the codes?
you can put your codes into a Public Module. it's still fine if you still want to keep the codes into 4 different sub routines, but you need to link all the relevant sub routines together.

for example:

you are calling Sub1, then you have:
Sub Sub1()
   'Do your stuffs..

   Call Sub2
End Sub

Sub Sub2()
   'Do your stuffs..

   Call SubN
End Sub

Open in new window

And when necessary, you can defined them as a Function instead of Sub so that a value can be returned from the piece of codes, so that you can determine whether the process within the codes is success or not.

hope this understandable and make sense.
1
 

Author Comment

by:Nirvana
ID: 41787439
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?
0
 
LVL 51

Expert Comment

by:Ryan Chong
ID: 41787540
>>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?
SnapShot.png
>>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.
0

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
This article descibes how to create a connection between Excel and SAP and how to move data from Excel to SAP or the other way around.
The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…
This Micro Tutorial demonstrate the bugs in Microsoft Excel for Mac with Pivot Charts.

830 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question