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

一把小刀闯天下

新时代新征途 发表于 2018-9-2 01:47
老师您好！谢谢帮助。有个想法：
1、能否把“明细表”中有多少城市就自动拆分多少个城市工作表。不需要 ...

'修改了一下，再试试

Option Explicit

Sub test()
  Dim arr, i, j, k, m, sum, brr, title, dic
  Call doevent(False)
  Set dic = CreateObject("scripting.dictionary")
  With Sheets("明细表")
    arr = .[a5].CurrentRegion.Offset(1)
    title = .Range("a4").Resize(, UBound(arr, 2))
  End With
  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
      With [a4].Resize(, UBound(title, 2))
        .Value = title
        .Borders.LineStyle = xlContinuous
      End With
    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
          With .Resize(m, UBound(brr, 2))
            .Value = brr
            .Borders.LineStyle = xlContinuous
          End With
          .Cells(m + 2, 1) = "合计"
          .Cells(m + 2, 7) = sum
        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

新时代新征途

一把小刀闯天下 发表于 2018-9-2 19:11
'修改了一下，再试试

Option Explicit

老师您好！谢谢您的关注。试了一下拆分后的工作表没有表头。

抽屉123

一把小刀闯天下 发表于 2018-9-2 19:11
'修改了一下，再试试

Option Explicit

一把小刀闯天下老师辛苦了！12楼的同学说的对，拆分后的工作没有表头。谢谢了！

一把小刀闯天下

新时代新征途 发表于 2018-9-2 19:31
老师您好！谢谢您的关注。试了一下拆分后的工作表没有表头。

你附件中本来就没表头，自己加上去或者把表头传上来

抽屉123

一把小刀闯天下 发表于 2018-9-2 19:54
你附件中本来就没表头，自己加上去或者把表头传上来

一把小刀闯天下老师：下面是我的原附件






                                
                               明细分解.zip (8.16 KB, 下载次数: 1)

2018-9-2 20:11 上传

点击文件名下载附件

lsc900707

抽屉123 发表于 2018-9-2 11:52
老师您好！谢谢您的帮助。有一点需要说明的也是重要的：

  1、在“明细表”“来源”I列中，如果有城市 ...

1. Private Sub CommandButton1_Click()
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     For Each sht In Sheets
   
5.         If sht.Name <> ActiveSheet.Name Then sht.Delete
   
6.     Next
   
7.     Application.DisplayAlerts = True
   
8.     Set d = CreateObject("scripting.dictionary")
   
9.     arr = [a4].CurrentRegion
   
10.     m = UBound(arr): n = UBound(arr, 2)
    
11.     For i = 2 To m
    
12.         If Len(arr(i, 9)) = 0 Then
    
13.             s = arr(i, 1)
    
14.         Else
    
15.             s = Replace(arr(i, 9), "转入", "")
    
16.         End If
    
17.         If Not d.exists(s) Then
    
18.             Set d(s) = Cells(i + 3, 1).Resize(1, n)
    
19.         Else
    
20.             Set d(s) = Union(d(s), Cells(i + 3, 1).Resize(1, n))
    
21.         End If
    
22.      Next
    
23.      x = d.keys
    
24.      For k = 0 To UBound(x)
    
25.          Set sht = ActiveWorkbook.Sheets.Add(, after:=ActiveSheet)
    
26.          With sht
    
27.              .Name = x(k)
    
28.              d.items()(k).Copy .[a5]
    
29.              Rows("4:4").Copy .[a4]
    
30.               .Columns.AutoFit
    
31.              r = .Cells(.Rows.Count, 1).End(3).Row
    
32.              Sum = 0
    
33.              For i = 5 To r
    
34.                 Sum = Sum + Val(.Cells(i, 7))
    
35.              Next
    
36.              .Cells(r + 2, 1) = "合计": .Cells(r + 2, 7) = Sum
    
37.              .UsedRange.Borders.LineStyle = 1
    
38.          End With
    
39.      Next
    
40.      Application.ScreenUpdating = True
    
41.      MsgBox "拆分完成!"
    
42. End Sub
    

复制代码

lsc900707

抽屉123 发表于 2018-9-2 11:52
老师您好！谢谢您的帮助。有一点需要说明的也是重要的：

  1、在“明细表”“来源”I列中，如果有城市 ...

代码又遇到审核，还是先回传附件好了：

抽屉123

lsc900707 发表于 2018-9-2 20:25
代码又遇到审核，还是先回传附件好了：

老师您做的这个模拟表是没有问题，但是，我把我实际的数据导入后，拆分的工作表中还现出了“某城市转入”的工作表（这个某城市转入是不应该有单独的工作表），而应该是从“明细表”拆分的“城市名”的工作表。就象您发的附件那样的。麻烦您再看看。谢谢！

lsc900707

抽屉123 发表于 2018-9-2 21:10
老师您做的这个模拟表是没有问题，但是，我把我实际的数据导入后，拆分的工作表中还现出了“某城市转入” ...

没有你的实际数据，我也难以确定问题所在。能上传你出错的附件吗？

抽屉123

lsc900707 发表于 2018-9-2 21:23
没有你的实际数据，我也难以确定问题所在。能上传你出错的附件吗？

版主您好！谢谢的无私相助。问题找到了。