Need advice on macro

[msquared99]

I have a macro that creates several folders, then takes data from one spreadsheet and creates several spreadsheets and saves them to a specific folder.

Next I need to add several Call Macros to format each file in each folder, there are 9 folders, what is my best option?

Should I setup a spreadsheet with the folder names and loop through them that way or just do it in the current macro.

Also, I need this as simple as possible because the end user is not very skilled.

Thanks!

 

[Kenneth Hobson]

Depends on what you are doing.

Is there a reason why you don't format each file before saving them?

Simple does not matter if all the user does is Open the workbook and it runs or clicks a Button to Run it.

A simple XLSM with the macro and folders to create and sample data and how to "format" it will help us help you.

 

[msquared99]

Kenneth:

Yes there is a reason, of the 9 folders created (see the top of the code where all the "MkDir" are), there is a different format for the spreadsheets in each folder.

So, with the code that I have, I am trying to figure out how to call a sub-macro to go through each of the files in folder and format them by using the main workbooks folder path. In other words, if X folder exists, then run this sub-macro. So, in the main macro I have a line of code:

FP = WBO.Path & Application.PathSeparator

This tells the location of the main workbook, which I would like to use in the sub-macro.

The original data is in the workbook that contains the main macro. That workbook will be saved to a different location each time, for instance 10-17 Files and then 11-17 Files and so on.

If the folder exists, how do I setup the sub-macro code to look for each folder and run through each of the files in the folder and format them by using the main workbooks path?

Sub Macro1()
  Dim WBO As Workbook 'original workbook
  Dim WBN As Workbook 'new workbook
  Dim WSO As Worksheet 'original worksheet
  Dim WSN As Worksheet 'new worksheet
  Dim r As Long
  Dim finalrow As Long
  Dim strDate As String
 
  MkDir ThisWorkbook.Path & "\Anico"
  MkDir ThisWorkbook.Path & "\Empower"
  MkDir ThisWorkbook.Path & "\MM"
  MkDir ThisWorkbook.Path & "\Voya1"
  MkDir ThisWorkbook.Path & "\Voya2"
  MkDir ThisWorkbook.Path & "\Voya3"
  MkDir ThisWorkbook.Path & "\Voya4"
  MkDir ThisWorkbook.Path & "\Voya5"
  MkDir ThisWorkbook.Path & "\Voya6"
 
  strDate = InputBox("Enter date as mm-dd-yy", "User date", Format(Now(), "mm-dd-yy"))
  If IsDate(strDate) Then
  strDate = Format(CDate(strDate), "mm-dd-yy")
  MsgBox strDate
  Else
  MsgBox "Incorrect date format!"
  End If
 
 
  Sheets("Template").Activate
 
  Set WBO = ActiveWorkbook
  Set WSO = ActiveSheet
 
  Application.ScreenUpdating = False
 
  finalrow = WSO.Cells(Rows.Count, 1).End(xlUp).Row + 1
 
  Cells.Replace What:="Dent Busters Inc.", Replacement:= _
  "Waldron Auto Body Inc.", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase _
  :=False, SearchFormat:=False, ReplaceFormat:=False
  Cells.Replace What:="Lancaster A-1 Auto Body Carstar", Replacement:= _
  "Waldron Auto Body Inc.", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase _
  :=False, SearchFormat:=False, ReplaceFormat:=False
  Cells.Replace What:="Thomas Waldron Auto Body LLC", Replacement:= _
  "Waldron Auto Body Inc.", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase _
  :=False, SearchFormat:=False, ReplaceFormat:=False
 
  Columns("A:A").Select
  Selection.Delete Shift:=xlToLeft
  Columns("F:J").Select
  Selection.Delete Shift:=xlToLeft
  Columns("H:L").Select
  Selection.Delete Shift:=xlToLeft
  Columns("A:A").Select
  Selection.Cut
  Columns("O:O").Select
  Selection.Insert Shift:=xlToRight
  Columns("G:L").Select
  Selection.Cut
  Columns("B:B").Select
  Selection.Insert Shift:=xlToRight
  Columns("K:L").Select
  Selection.Cut
  Columns("H:H").Select
  Selection.Insert Shift:=xlToRight
  Columns("K:L").Select
  Selection.Cut
  Columns("J:J").Select
  Selection.Insert Shift:=xlToRight
  Columns("M:M").Select
  Selection.Delete Shift:=xlToLeft
  Cells.Select
  Selection.AutoFilter
  ActiveSheet.Range("$A$1:$AI$" & finalrow).AutoFilter Field:=2, Criteria1:="0"
  ActiveSheet.Range("$A$1:$AI$" & finalrow).AutoFilter Field:=3, Criteria1:="0"
  ActiveSheet.Range("$A$1:$AI$" & finalrow).AutoFilter Field:=4, Criteria1:="0"
  ActiveSheet.Range("$A$1:$AI$" & finalrow).AutoFilter Field:=7, Criteria1:="0"
  Rows("2:" & finalrow).Select
  Selection.Delete Shift:=xlUp
  Selection.AutoFilter
  Range("A1").Select
  ActiveCell.FormulaR1C1 = "SSN"
  Range("B1").Select
  ActiveCell.FormulaR1C1 = "Deferral"
  Range("D1").Select
  ActiveCell.FormulaR1C1 = "SHM"
  Range("E1").Select
  ActiveCell.FormulaR1C1 = "Disc"
  Range("F1").Select
  ActiveCell.FormulaR1C1 = "PS"
  Range("G1").Select
  ActiveCell.FormulaR1C1 = "Loan"
  Range("J1").Select
  ActiveCell.FormulaR1C1 = " First Name"
  Range("K1").Select
  ActiveCell.FormulaR1C1 = " M.I."
  Range("L1").Select
  ActiveCell.FormulaR1C1 = " Last Name"
  Range("A1").Select
 
 
  Workbooks.Open Filename:= _
  "C:\RMI Vendor List.xlsx"
  WBO.Activate
  Application.Calculation = xlCalculationAutomatic
 
  WSO.Range("N2").Select
 
  ActiveCell.FormulaR1C1 = _
  "=VLOOKUP(RC[-1],'RMI Vendor List.xlsx'!VendorTbl[#Data],2,0" & Chr(10) & ")"
  With WSO.Range("N2")
  .AutoFill Destination:=Range("N2:N" & finalrow)
  End With
 
  WSO.Sort.SortFields.Clear
  WSO.Sort.SortFields.Add Key:=Range("N2:N" & finalrow), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
  xlSortNormal
  With WSO.Sort
  .SetRange Range("A1:N" & finalrow)
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
  End With
  Columns("N:N").Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Range("A2").Select
 
  Cells.Find(What:="#N/A", After:=ActiveCell, LookIn:=xlFormulas, LookAt _
  :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
  False, SearchFormat:=False).Activate
  Range(Selection, Selection.End(xlDown)).Select
  Selection.EntireRow.Delete
 
  'sort data
  WSO.Range("A1:N" & finalrow).Select
  WSO.Sort.SortFields.Clear
  Selection.Sort Key1:=Range("M2"), Order1:=xlAscending, Header:=xlGuess, Orientation:=xlSortColumns
  With ActiveWorkbook.Worksheets("Template").Sort
  .SetRange Range("A1:N" & finalrow)
  .Header = xlYes
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
  End With
 
  Range("A2").Select
 
  LastClient = Cells(2, 13)
  startrow = 2
 
  For r = 2 To finalrow
  ThisClient = WSO.Cells(r, 13)
  If ThisClient = LastClient Then
 
  Else
  lastrow = r - 1
  RowCount = lastrow - startrow + 1
 
  Set WBN = Workbooks.Add(template:=xlWBATWorksheet)
  Set WSN = WBN.Worksheets(1)
 
  WSN.Name = "Sheet1"
 
  WSO.Range("A1:M1").Copy Destination:=WSN.Cells(1, 1)
 
  WSO.Range(WSO.Cells(startrow, 1), WSO.Cells(lastrow, 14)).Copy Destination:=WSN.Cells(2, 1)
 
  FN = "\" & WSN.Range("N2") & "\" & LastClient & " " & strDate & ".xlsx"
  FP = WBO.Path & Application.PathSeparator
  WBN.SaveAs Filename:=FP & FN
  WBN.Close SaveChanges:=False
 
  LastClient = ThisClient
  startrow = r
  End If
  Next r
 
  Workbooks("RMI Vendor List.xlsx").Close SaveChanges:=Fales
 
 
  Application.ScreenUpdating = True
 
End Sub

 

[msquared99]

Here is some example code I would use as a sub-macro:

Sub AnicoFormat()

'This macro works

Dim MyFolder As String, MyFile As String
Dim ws As Worksheet, wb As Workbook


MyFolder = "C:\Testing\Anico"
MyFile = Dir(MyFolder & "\*.xl*")

  Do While MyFile <> ""
  Workbooks.Open Filename:=MyFolder & "\" & MyFile
  MyFile = Dir
  Loop
  
  
  For Each wb In Workbooks
  wb.Activate
  If ActiveWorkbook.Name <> ThisWorkbook.Name Then
  'This is where you do stuff
  Columns("M:N").Select
  Selection.Delete shift:=xlToLeft
  Range("L1").Select
  Selection.EntireRow.Delete
  Range("A1").Select
  
  wb.Close savechanges:=True
  End If
  
  Next wb

End Sub

I would like to substitute MyFolder and MyFile for the master workbooks file location.

 

[Kenneth Hobson]

I guess maybe you want to use Application.Run? It lets you pass the name of the macro to run as a string. You can also pass parameter values to the Sub in the Application.Run. e.g.

Sub Test_Button807_Click()
  Application.Run "'" & ThisWorkbook.Path & "\RunExample.xlsm'!Module2.Button807_Click", 3
End Sub

I would suggest modifying your macros before you get to far into it. Activate, Select, Selection, and such are seldom needed. This link shows that sort of thing. http://www.tushar-mehta.com/excel/vba/beyond_the_macro_recorder/index.htm

If those are static folder names, I would put them into an array so I could iterate it and re-use it maybe. If they are static, and the format submacros are small as shown in that one, I would use a Select Case and skip the calls to submacros.

If the folders are not static, I would use a batch macro to get all subfolder files and iterate it. You can parse out the folder name and file names as needed. Since it know all the folder and file names, there is no need for Dir() or its Loop in each submacro.

Here is my batch macro with a test example. You can easily add the wildcard search as you used in the VBA Dir() method. This method gives you lots of power. I provided a link showing the help for what all the shell's DIR can do.

Sub test_aFFs()
  Dim x() As Variant

  x() = aFFs("x:\t\")
  MsgBox Join(x(), vbLf)
  MsgBox x(0), vbInformation, "First File"
  MsgBox x(1), vbInformation, "Second File"

  x() = aFFs("x:\t*", "/ad")  'Search for folders in x:\ that start with the letter "t".
  MsgBox Join(x(), vbLf)

  x() = aFFs("x:\t*", "/ad", True) 'Search for subfolders in x:\ that start with the letter "t".
  MsgBox Join(x(), vbLf)
End Sub

'Set extraSwitches, e.g. "/ad", to search folders only.
'MyDir should end in a "\" character unless searching by wildcards, e.g. "x:\test\t*
'Command line switches for the shell's Dir, http://ss64.com/nt/dir.html
Function aFFs(myDir As String, Optional extraSwitches = "", _
  Optional tfSubFolders As Boolean = False) As Variant

  Dim s As String, a() As String, v As Variant
  Dim b() As Variant, i As Long

  If tfSubFolders Then
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b /s " & extraSwitches).StdOut.readall
    Else
    s = CreateObject("Wscript.Shell").Exec("cmd /c dir " & _
      """" & myDir & """" & " /b " & extraSwitches).StdOut.readall
  End If

  a() = Split(s, vbCrLf)
  If UBound(a) = -1 Then
    Debug.Print myDir & " not found.", vbCritical, "Macro Ending"
    Exit Function
  End If
  ReDim Preserve a(0 To UBound(a) - 1) As String 'Trim trailing vblfcr

  For i = 0 To UBound(a)
    If Not tfSubFolders Then
      s = Left$(myDir, InStrRev(myDir, "\"))
      'add the folder name
      a(i) = s & a(i)
    End If
  Next i
  aFFs = sA1dtovA1d(a)
End Function

Function sA1dtovA1d(strArray() As String) As Variant
  Dim varArray() As Variant, i As Long
  ReDim varArray(LBound(strArray) To UBound(strArray))
  For i = LBound(strArray) To UBound(strArray)
    varArray(i) = CVar(strArray(i))
  Next i
  sA1dtovA1d = varArray()
End Function

 

[msquared99]

Thanks Kenneth!

I'll play around with this and let you know.

Mike