VBA: Condensing 2 set of codes into 1

[MrOnyx]

Hi everyone! I'm quite new at the whole VBA area, as I'm just trying to pick up some of the knowledge for my work. I have done a bit of macro recording and a lot of Google search to come up with the 2 macros below.

The situation is that I have a set of data sheet fixed from column A to P with at least 100k+ lines of data (changes overtime). I'm looking to focus on column H and 'i' where i is the city and H being the assignment #. I run the first macro to break out each city in column i into separate tabs and then create a new workbook for it. Each workbook to be named after the city name. I then run the second macro where under each city's workbook, it breaks out each assignment into its own tab. The end result would be a new workbook for each city, and within the workbook, there are a tab for each of the unique assignments. I'm not sure how to combine these codes and make it easier overall.

Code 1: Filter each unique city in column i and create a new workbook for each one with the associated data.

‘Code 1
Sub Macro1()
Dim shA As Worksheet
Dim FilterRng As Range
Dim CopyRng As Range
Dim lastrow As Long
Dim UniqueFunction()
Dim destSh As Worksheet
Dim C As Long
Dim FirstCell As Range
ActiveSheet.Name = "Data"
Set shA = Worksheets("Data[B]")
lastrow = shA.Range("A1").End[/B](xlDown).Row
Set FilterRng = shA.Range("I1:I" & lastrow)
Set CopyRng = shA.Range("I2:I" & lastrow)
C = 1
FilterRng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ReDim UniqueFunction(1 To CopyRng.SpecialCells(xlCellTypeVisible).Cells.Count)
For Each cell In CopyRng.SpecialCells(xlCellTypeVisible).Cells
UniqueFunction(C) = cell.Text
C = C + 1
Next
shA.ShowAllData
For C = LBound(UniqueFunction) To UBound(UniqueFunction)
FilterRng.AutoFilter Field:=1, Criteria1:=UniqueFunction(C)
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(UniqueFunction(C)).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set destSh = Worksheets.Add(After:=Sheets(Sheets.Count))
SheetName = Replace(UniqueFunction(C), "/", "")
If SheetName = "" Then
SheetName = "BlankBranch"
End If
destSh.Name = SheetName
destSh.Range("A1") = UniqueFunction(C)
shA.Range("A1:P" & lastrow).SpecialCells(xlCellTypeVisible).Copy destSh.Range("A2")
rw = destSh.Range("A" & Rows.Count).End(xlUp).Row
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Cells.Select
Selection.RowHeight = 12.75
Range("a1").Select
Next
FilterRng.AutoFilter
ActiveWorkbook.Worksheets(1).Activate
Dim sht As Worksheet
Dim w As Worksheet
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each sht In Worksheets
Set neww = Workbooks.Add
sht.Copy neww.Worksheets(1)
With neww
For Each w In Worksheets
If w.Name <> sht.Name Then
w.Delete
End If
Next w
End With
neww.SaveAs sht.Parent.Path & "\" & sht.Name
neww.Close
Next sht
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Code 2: loop in the same folder where all the previous created workbook exists and create a tab for each of the unique assignments in column H.

Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.xls*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
Dim shA As Worksheet
Dim FilterRng As Range
Dim CopyRng As Range
Dim lastrow As Long
Dim UniqueFunction()
Dim destSh As Worksheet
Dim C As Long
Dim FirstCell As Range
ActiveSheet.Name = "Data"
Set shA = Worksheets("Data[B]")
lastrow = shA.Range("A1").End[/B](xlDown).Row
Set FilterRng = shA.Range("H1:H" & lastrow)
Set CopyRng = shA.Range("H2:H" & lastrow)
C = 1
FilterRng.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
ReDim UniqueFunction(1 To CopyRng.SpecialCells(xlCellTypeVisible).Cells.Count)
For Each cell In CopyRng.SpecialCells(xlCellTypeVisible).Cells
UniqueFunction(C) = cell.Text
C = C + 1
Next
shA.ShowAllData
For C = LBound(UniqueFunction) To UBound(UniqueFunction)
FilterRng.AutoFilter Field:=1, Criteria1:=UniqueFunction(C)
On Error Resume Next
Application.DisplayAlerts = False
Worksheets(UniqueFunction(C)).Delete
Application.DisplayAlerts = True
On Error GoTo 0
Set destSh = Worksheets.Add(After:=Sheets(Sheets.Count))
SheetName = Replace(UniqueFunction(C), "/", "")
If SheetName = "" Then
SheetName = "BlankBranch"
End If
destSh.Name = SheetName
destSh.Range("A1") = UniqueFunction(C)
shA.Range("A1:P" & lastrow).SpecialCells(xlCellTypeVisible).Copy destSh.Range("A2")
rw = destSh.Range("A" & Rows.Count).End(xlUp).Row
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Cells.Select
Selection.RowHeight = 12.75
Range("a1").Select
Next
FilterRng.AutoFilter
ActiveWorkbook.Worksheets(1).Activate
End With
ActiveWorkbook.Save
ActiveWindow.Close
xFileName = Dir
Loop
End If
End Sub

 

[Joe4]

Welcome to the Board!

I'm not sure how to combine these codes and make it easier overall.

If everything is working fine, there is no need to combine them.
As matter as fact, many experts will tell you to keep your procedures/functions shorter, breaking them into logical segments, for ease in debugging and re-using later.

Many times, I will have a controlling "Main" sub procedure where I call my other procedures from, i.e.

Sub MainProc()
    Call Macro1
    Call Macro2
End Sub

Sub Macro1()
'   Do something
End Sub

Sub Macro2()
'   Do something
End Sub

 

[vw412]

I will need a workbook with a representative set of data (not all 100k+ lines) that will have multiple cities and multiple assignments per city to test what I am doing and to understand what it is you want to do. If you could upload such wockbook to a location and send link to it that would be great.

Your code looks like you got most of it from the Macro Recorder. Since you say you want to become more knowledgable for your work, I will try to show you some VBA and explain the process of arriving at it so you can hopefully have a few more tools in your workbelt for the future. Generally speaking, a programmer is not someone who knows a program language. A programmer is a "problem solver" who uses a program language to define and solve problems. So the first step in programming is to define the problem in as much detail as possible before trying to put it into a program language. For me, one step in doing that is to step through the problem manually and record what I do to reach a solution. The Macro Recorder can help with this in Excel but it also introduces a lot of noise into the solution that is required for the Excel UI but counter-productive in getting to a good solution.

If you can get me that representative data workbook I will see what we can do.