Excel 워크북의 분할

Option Explicit

Sub  ()
Application.ScreenUpdating = True
Dim br, x As Integer, sh As Worksheet, d As New Dictionary, i As Integer, rg As Range, k As Integer, j As Integer, arr(), l As Integer
i = Range("A2").End(xlDown).Row
For Each rg In Range("H3:H" & i)
    d(rg.Value) = ""
Next

For k = 0 To d.Count - 1
    For j = 3 To i
     If Range("H" & j) = d.Keys(k) Then
        x = x + 1
        ReDim Preserve arr(1 To 12, 1 To x)
        arr(1, x) = x
        arr(2, x) = Range("B" & j)
        arr(3, x) = Range("C" & j)
        arr(4, x) = Range("D" & j)
        arr(5, x) = Range("E" & j)
        arr(6, x) = Range("F" & j)
        arr(7, x) = Range("G" & j)
        arr(8, x) = Range("H" & j)
        arr(9, x) = Range("I" & j)
        arr(10, x) = Range("J" & j)
        arr(11, x) = Range("K" & j)
        arr(12, x) = Range("L" & j)
        
     End If
    Next j
   Set sh = Sheets.Add(, Sheets(Sheets.Count))
   sh.Name = d.Keys(k)
   sh.Range("a1:l1").Merge
   sh.Range("a1") = " 2015 9 21 2015     "
   sh.Range("a1").HorizontalAlignment = xlCenter
   sh.Range("a2:L2") = Array(" ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ", " ")
   sh.Range("a3").Resize(UBound(arr, 2), 12) = WorksheetFunction.Transpose(arr)
   sh.Range("a3:L" & (UBound(arr, 2) + 2)).HorizontalAlignment = xlCenter
  br = Array(6.5, 17, 8.38, 11, 16, 15, 12, 12, 8.38, 8.38, 10, 30)
   For x = 1 To 12
    sh.Columns(x).ColumnWidth = br(x - 1)
   Next x
   
   Erase arr: x = 0
   Sheets(" ").Activate
Next k
Application.ScreenUpdating = False
End Sub