Office学习社区 › 公式和函数 › Excel汇总表拆分成明细表

夏之荷 发表于 2021-10-27 12:48:36

谢谢！！！辛苦啦！！真的太感谢了

用户难忘 发表于 2021-10-30 13:36:12

Sub 拆分()
Application.ScreenUpdating = False
Dim d As Object
Dim ar As Variant, br As Variant
Dim i As Long
Dim arr()
Set d = CreateObject("scripting.dictionary")
For Each sh In Sheets
If sh.Name <> "汇总" Then
d(sh.Name) = ""
End If
Next sh
With Sheets("汇总")
r = .Cells(Rows.Count, 58).End(xlUp).Row
ar = .Range("a1:bg" & r)
End With
For i = 2 To UBound(ar)
n = 0
ReDim arr(1 To UBound(ar), 1 To 6)
If Trim(ar(i, 58)) <> "" Then
For j = 2 To 57 Step 4
    If Trim(ar(i, j)) <> "" Then
      n = n + 1
      arr(n, 1) = n
      arr(n, 2) = ar(i, 58)
      arr(n, 3) = ar(i, j)
      arr(n, 4) = ar(i, j + 1)
      arr(n, 5) = ar(i, j + 2)
      arr(n, 6) = ar(i, j + 3)
    End If
Next j
If n > 0 Then
    mc = Trim(ar(i, 58))
    If Not d.exists(Trim(ar(i, 58))) Then
      Set sht = Worksheets.Add(after:=Sheets(Sheets.Count))
      With ActiveSheet
      .Name = mc
      ..Resize(1, 6) = Array("序号", "名称", "开始时间", "作业时间", "作业内容", "周期")
      ..Resize(n, UBound(arr, 2)) = arr
      End With
    Else
      With Sheets(mc)
      rs = .Cells(Rows.Count, 58).End(xlUp).Row
      .Range("a2:f" & rs) = Empty
      ..Resize(n, UBound(arr, 2)) = arr
      End With
    End If
End If
End If
Next i
MsgBox "ok!"
End Sub
'

前文 发表于 2021-11-10 04:39:33

你说没有重复，其实是有重复的，所以，代码仅供参考

懒得想名字 发表于 2021-11-15 14:01:24

辛苦辛苦！因为是从个分区收上来的表！我在检查下！谢谢您啦

会过去的 发表于 2021-11-19 00:51:17

用VBA，或者换一种思路，搞一张查询表，根据名称来提取符合名称的所有行

继成王者 发表于 2021-11-20 20:55:11

规范表，然后透视即可

牵着白蛇念咒 发表于 2021-11-24 11:13:25

1、这是vba才能做的事情，
2、看不懂你模拟的结果，比如，第46435工作表中的名称D45435从何而来？
3、汇总表中BF列的数据是不是唯一的没有重复？？

孙海涛 发表于 2021-11-28 07:03:15

2楼、3楼说的查询和透视的办法都很好，就是源表需要好好规范一下。题主例子里一个名称建一个表就至少要80个表，到时候用起来也不方便。

猫崽 发表于 2021-11-30 12:16:51

是唯一没有重复的！表标签那里我写错了！就是把这80行拆成80张表

丞哥朱爸 发表于 2021-12-8 06:55:26

用VBA，或者换一种思路，搞一张查询表，根据名称来提取符合名称的所有行

查看完整版本: Excel汇总表拆分成明细表