Isso é remendado, mas funciona para mim. Altere o destino e o cabeçalho "Estado", se necessário. Você também pode alterar o filtro se sua planilha for mais complicada do que apenas duas colunas.
Option Explicit
Sub CreateCSVfromWS()
Dim ws As Worksheet
Application.ScreenUpdating = False
Call Filter
Call MakeMonthSheets
For Each ws In ActiveWorkbook.Worksheets
ws.SaveAs "C:\Destination\" & ws.Name & ".csv", xlCSV
Next
Application.ScreenUpdating = True
End Sub
Sub Filter()
Columns("A:B").Select
Selection.AutoFilter
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort.SortFields.Add Key:=Range _
("B:B"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End Sub
Sub MakeMonthSheets()
Dim rngState As Range
Dim rngCell As Range
Dim sh As Worksheet
Dim shDest As Worksheet
Dim rngNext As Range
Const sLNHEADER As String = "State"
Set sh = ThisWorkbook.Sheets("Sheet1")
Set rngState = sh.UsedRange.Find(sLNHEADER, , xlValues, xlWhole)
'Make sure you found something
If Not rngState Is Nothing Then
'Go through each cell in the column
For Each rngCell In Intersect(rngState.EntireColumn, sh.UsedRange).Cells
'skip the header and empty cells
If Not IsEmpty(rngCell.Value) And rngCell.Address <> rngState.Address Then
'see if a sheet already exists
On Error Resume Next
Set shDest = sh.Parent.Sheets(rngCell.Value)
On Error GoTo 0
'if it doesn't exist, make it
If shDest Is Nothing Then
Set shDest = sh.Parent.Worksheets.Add
shDest.Name = rngCell.Value
End If
'Find the next available row
Set rngNext = shDest.Cells(shDest.Rows.Count, 1).End(xlUp).Offset(1, 0)
'Copy and paste
Intersect(rngCell.EntireRow, sh.UsedRange).Copy rngNext
'reset the destination sheet
Set shDest = Nothing
End If
Next rngCell
End If
End Sub