Solved

consolidate or create a new vba code for performing tasks

Posted on 2016-09-06
5
1 solution
77 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
[X]
Welcome to Experts Exchange

Add your voice to the tech community where 5M+ people just like you are talking about what matters.

  • Help others & share knowledge
  • Earn cash & points
  • Learn & ask questions
Join The Community
  • 3
  • 2
5 Comments
 
LVL 52

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 52

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 52

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: Port Scanner

Check which ports are open to the outside world. Helps make sure that your firewall rules are working as intended.

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.

Access It Now
Question has a verified solution.

If you are experiencing a similar issue, please ask a related question
Create Windows Phone Colour Palette and Selector using WithEvents
Article by: Gustav
The Windows Phone Theme Colours is a tight, powerful, and well balanced palette. This tiny Access application makes it a snap to select and pick a value. And it doubles as an intro to implementing WithEvents, one of Access' hidden gems.
Deleting Shapes - A Warning
Article by: Martin
This article describes a serious pitfall that can happen when deleting shapes using VBA.
Creating a Scrolling Table in Excel
Video by: AnnieCushing
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.
Enumerating Prime Numbers in Excel / VBA
Video by: Ed
Finds all prime numbers in a range requested and places them in a public primes() array. I've demostrated a template size of 30 (2 * 3 * 5) but larger templates can be built such 210  (2 * 3 * 5 * 7) or 2310  (2 * 3 * 5 * 7 * 11). The larger templa…
Advertise Here

695 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

Advertise Here