View Single Post
  #6   Report Post  
Posted to microsoft.public.excel.misc
Ardus Petus
 
Posts: n/a
Default Macro to Automate Saving

Here is your macro.

See example: http://cjoint.com/?ftkyKVoGnc

HTH
--
AP

'-------------
Option Explicit

Sub SaveBranches()

Dim rBranch As Range
Dim lBranchCount As Long

' Create list of unique Branch codes
Range("A1:A9").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("I1"), Unique:=True
' Check list size
lBranchCount = Range("I1").End(xlDown).Row - 1
If lBranchCount = Rows.Count - 1 Then
MsgBox "Empty Branch list"
Exit Sub
End If
' Loop thru branches
For Each rBranch In Range("I2").Resize(lBranchCount)
' Filter data pertaining to current branch
Range("A1:G1").AutoFilter Field:=1, Criteria1:=rBranch.Value
' Copy filtered data
Range("A1").CurrentRegion.Copy
' Create new workbook
Workbooks.Add
' Paste data, formats & col width
Range("A1").PasteSpecial Paste:=xlPasteAll
' Save workbook
With ActiveWorkbook
Application.DisplayAlerts = False
.SaveAs _
Filename:=ThisWorkbook.Path & "\" & rBranch.Value & ".xls"
Application.DisplayAlerts = True
.Close
End With
' Get back to data workbook
ThisWorkbook.Activate
Next rBranch
' Clean up
ActiveSheet.AutoFilterMode = False
Range("I1").Resize(lBranchCount + 1).ClearContents

End Sub
'----------