Sub Split_File_Into_Multiple_Files()
Dim wb2 As Workbook, wb1 As Workbook
Dim sh As Worksheet
Dim dic As Object, ky As Variant
Dim a() As Variant, b() As Variant, c() As Variant
Dim shfrm As String, nameAnt As String
Dim nCont As Long, nYear As Long
Dim i%, j%, k%, n%, lr%
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.StatusBar = False
Set wb1 = ThisWorkbook
Set dic = CreateObject("Scripting.Dictionary")
For Each sh In wb1.Sheets
If sh.Range("A1").Value = "ITEM" Then
If shfrm = "" Then shfrm = sh.Name
nCont = nCont + sh.Range("A" & Rows.Count).End(3).Row
End If
Next
ReDim b(1 To nCont, 1 To 9)
For Each sh In Sheets
Erase a
If sh.Range("A1").Value = "ITEM" Then
a = sh.Range("A2", sh.Range("H" & Rows.Count).End(3)).Value
For i = 1 To UBound(a, 1)
If a(i, 3) <> "" Then
k = k + 1
nYear = Year(a(i, 2))
dic(nYear) = Empty
For j = 1 To UBound(a, 2)
b(k, j) = a(i, j)
Next
b(k, 9) = nYear
End If
Next
End If
Next
Set wb2 = Workbooks.Add(xlWBATWorksheet)
With wb2.Sheets(1)
wb1.Sheets(shfrm).Rows(1).Copy .Range("A1")
.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
.Range("A1:I" & UBound(b, 1)).Sort .Range("I2"), xlAscending, .Range("C2"), , xlAscending, .Range("B2"), xlAscending, xlYes
Erase a
a = .Range("A2", Range("I" & Rows.Count).End(3)).Value
End With
wb2.Close False
For Each ky In dic.keys
Application.StatusBar = "Creating book: " & ky
k = 0
ReDim c(1 To UBound(a, 1), 1 To 8)
For i = 1 To UBound(a, 1)
If Year(a(i, 2)) = ky Then
k = k + 1
For j = 1 To UBound(a, 2) - 1
c(k, j) = a(i, j)
Next
End If
Next
nameAnt = c(1, 3)
k = 0
n = 0
ReDim b(1 To UBound(c, 1) + 1000, 1 To 8)
For i = 1 To UBound(c, 1)
If nameAnt <> c(i, 3) Then 'corte nombre
k = k + 1
b(k, 1) = "BALANCE"
b(k, 8) = tot
tot = 0
n = 0
If c(i, 3) = "" Then Exit For
End If
tot = tot + c(i, 8)
k = k + 1
n = n + 1
b(k, 1) = n
For j = 2 To UBound(c, 2)
b(k, j) = c(i, j)
Next
nameAnt = c(i, 3)
Next
Set wb2 = Workbooks.Add(xlWBATWorksheet)
With wb2.Sheets(1)
wb1.Sheets(shfrm).Range("A1:H1").Copy
.Range("A1").PasteSpecial xlPasteAll
.Range("A1").PasteSpecial xlPasteColumnWidths
.Range("A2").Resize(UBound(b, 1), UBound(b, 2)).Value = b
lr = .Range("A" & Rows.Count).End(3).Row
wb1.Sheets(shfrm).Range("A2").Copy
.Range("A2:E" & lr).PasteSpecial xlPasteFormats
wb1.Sheets(shfrm).Range("B2").Copy
.Range("B2:B" & lr).PasteSpecial xlPasteFormats
wb1.Sheets(shfrm).Range("H2").Copy
.Range("F2:H" & lr).PasteSpecial xlPasteFormats
Application.FindFormat.Clear
Application.ReplaceFormat.Clear
With Application.ReplaceFormat.Font
.FontStyle = "Bold"
.Subscript = False
.Color = 255
.TintAndShade = 0
End With
.Range("A:A").Replace "BALANCE", "BALANCE", xlWhole, , False, False, SearchFormat:=True
End With
wb2.SaveAs wb1.Path & "\" & "FILE_" & ky, xlOpenXMLWorkbook
wb2.Close False
Next
Application.StatusBar = False
Application.FindFormat.Clear
Application.ReplaceFormat.Clear
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
