VBA格式化工作簿示例

Sub Reformat()
 Dim aryColD() As String
 Dim cntColD As Long
 Dim i As Long
 Dim rowLast As Long
 Dim rowLastInBlock As Long
 
 Application.ScreenUpdating = False
 
 With Worksheets("Sheet1")
   .ResetAllPageBreaks
 
   rowLast = .Cells(.Rows.Count, 1).End(xlUp).Row
 
   cntColD = 1
   ReDim Preserve aryColD(1 To cntColD)
   aryColD(cntColD) = 1
 
   For i = 2 To rowLast - 1
     If .Cells(i, 3).Value <> .Cells(i + 1, 3).Value Then
       cntColD = cntColD + 1
       ReDim Preserve aryColD(1 To cntColD)
       aryColD(cntColD) = i + 1
     End If
   Next i
   For i = UBound(aryColD) To LBound(aryColD) Step -1
     Application.StatusBar = "处理行" & i 
     Worksheets("Sheet2").Rows(1).Copy
     .Rows(aryColD(i)).Insert Shift:=xlDown
 
     .Rows(aryColD(i)).Insert Shift:=xlDown
     .Cells(aryColD(i), 1).Value = .Cells(aryColD(i) + 2, 3).Value
     .Cells(aryColD(i), 1).Font.Bold = True
 
     rowLastInBlock = .Cells(aryColD(i), 1).End(xlDown).Row
 
     With .Cells(aryColD(i) + 1, 1).Resize(rowLastInBlock - aryColD(i), 4).Borders
       .LineStyle = xlContinuous
       .ColorIndex = 0
       .TintAndShade = 0
       .Weight = xlThin
     End With
 
     If aryColD(i) > 1 Then .HPageBreaks.Add Before:=.Rows(aryColD(i))
   Next i
 End With
 Application.StatusBar = False
 Application.ScreenUpdating = True
 
 MsgBox "完成"
End Sub