请帮助解决明细分解的问题

一把小刀闯天下

抽屉123 发表于 2018-9-2 20:11
一把小刀闯天下老师：下面是我的原附件

'还是没有表头，按明细表的表头、格式来设置分表

'你这1-3行都为空，它才叫表头，第4行叫标题

Option Explicit

Sub test()
  Dim arr, i, j, k, m, sum, brr, dic
  Call doevent(False)
  Set dic = CreateObject("scripting.dictionary")
  arr = Sheets("明细表").[a5].CurrentRegion.Offset(1)
  brr = arr
  For i = 1 To UBound(arr, 1) - 1: dic(arr(i, 1)) = vbNullString: Next
  For Each i In Sheets
    If i.Name <> "明细表" Then Sheets(i.Name).Delete
  Next
  For Each i In dic.keys
    If i <> "明细表" Then
      Sheets.Add
      ActiveSheet.Name = i
      Sheets("明细表").Cells.Copy [a1]
    End If
  Next
  For i = 1 To UBound(arr, 1) - 1
    If Len(arr(i, 9)) = 0 Then
      m = m + 1: sum = sum + arr(i, 7)
      For j = 1 To UBound(arr, 2): brr(m, j) = arr(i, j): Next
    End If
    If arr(i + 1, 1) <> arr(i, 1) Then
      For j = 1 To UBound(arr, 1) - 1
        If InStr(arr(j, 9), arr(i, 1)) Then
          m = m + 1: sum = sum + arr(j, 7)
          For k = 1 To UBound(arr, 2): brr(m, k) = arr(j, k): Next
        End If
      Next
      With Sheets(arr(i, 1)).[a5]
        If m > 0 Then
          .Resize(m, UBound(brr, 2)) = brr
          .Offset(m).Resize(Rows.Count - m - 4, UBound(brr, 2)).Clear
          .Cells(m + 2, 1) = "合计"
          .Cells(m + 2, 7) = sum
        Else
          .Resize(Rows.Count - 4, UBound(brr, 2)).Clear
        End If
      End With
      m = 0: sum = 0
    End If
  Next
  Call doevent(True)
End Sub

Function doevent(flag)
  With Application
    .DisplayAlerts = flag
    .ScreenUpdating = flag
  End With
End Function

抽屉123

一把小刀闯天下 发表于 2018-9-2 23:54
'还是没有表头，按明细表的表头、格式来设置分表

'你这1-3行都为空，它才叫表头，第4行叫标题

一把小刀闯天下老师谢谢您！您说的对，就是每个拆分后的工作表没有标题（在每个表的第四行）。

以下就标题

城市名

日期

信息1

主要日期

日期1

信息2

金额

信息4

来源

信息6

信息7

信息8

信息9

信息10

信息11

信息12

信息13

信息14

信息15