A macro a seguir divide a folha principal em grupos. O número de colunas e linhas é insignificante. Somente a última coluna é importante, pois a macro depende do mapeamento entre o nome da planilha e o nome do código. Se a planilha com um determinado valor de código não existir, o registro permanecerá intocado na planilha principal. Como um deve ter o nome do código deve estar na última coluna.
Option Explicit
'Assumptions:
'The Code is in the last column
Sub DataSplitter()
Application.ScreenUpdating = False
On Error Resume Next
Dim noOfRows As Long
Dim noOfColumns As Long
Dim noOfRowsInCodeSheet As Variant
Dim i As Long 'counter
Dim j As Long 'counter
Dim sE As Boolean 'sheet exists flag
Dim sheetEmpy As Boolean
Dim code As String
Dim c As New Collection 'store noOfRowsInCodeSheet
Dim cRows As New Collection 'rows to delete
j = 1
'check how many columns
Do While Len(Cells(1, j).Value) > 0
j = j + 1
Loop
noOfColumns = j - 1
'check how many rows
i = 1
Do While Len(Cells(i, 1).Value) > 0
i = i + 1
Loop
noOfRows = i - 1
'loop through the data
For i = 2 To noOfRows
code = Cells(i, noOfColumns).Value
'check if sheet exists
If Sheets(code) Is Nothing Then
sE = False ' sheet with code name does not exist
Else
sE = True ' sheet with code name exists
End If
'if sheet exists then check the noOfRows based on code
If sE = True Then
noOfRowsInCodeSheet = c.Item(code)
If noOfRowsInCodeSheet Is Empty Then
'the sheet was not visited during this execution
'check no of rows in code sheet
j = 1
Do While Len(Sheets(code).Cells(j, 1).Value) > 0
j = j + 1
Loop
noOfRowsInCodeSheet = j - 1
If noOfRowsInCodeSheet = 0 Then
'add headers
For j = 0 To noOfColumns
Sheets(code).Cells(1, j).Value = Cells(1, j).Value
Next j
noOfRowsInCodeSheet = noOfRowsInCodeSheet + 1
End If
If noOfRowsInCodeSheet >= 1 Then
noOfRowsInCodeSheet = noOfRowsInCodeSheet + 1
'populate rows
For j = 1 To noOfColumns
'Sheets(code).Cells(noOfRowsInCodeSheet, j).Value = Cells(i, j).Value 'it works but looses formatting
Cells(i, j).Copy
Sheets(code).Cells(noOfRowsInCodeSheet, j).PasteSpecial Paste:=xlPasteFormats
Sheets(code).Cells(noOfRowsInCodeSheet, j).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
Next j
c.Remove code
c.Add Item:=noOfRowsInCodeSheet, Key:=code
cRows.Add Item:=i, Key:=CStr(i)
End If
End If
Else
'if sheet does not exist then do nothing (it's possible to _
'automatically add it if required)
End If
Next i
‘Uncomment to MOVE (cut-paste) rows (3 below lines)
‘Comment to COPY (copy-paste) rows (3 below lines)
For j = cRows.Count To 1 Step -1
Rows(cRows.Item(j)).EntireRow.Delete
Next j
Application.ScreenUpdating = True
End Sub