Excel汇总表拆分成明细表

夏之荷

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

用户难忘

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
      .[a1].Resize(1, 6) = Array("序号", "名称", "开始时间", "作业时间", "作业内容", "周期")
      .[a2].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
      .[a2].Resize(n, UBound(arr, 2)) = arr
      End With
    End If
  End If
  End If
Next i
MsgBox "ok!"
End Sub
  '

前文

工作簿1.rar (56.46 KB, 下载次数: 163)

2021-10-6 12:14 上传

点击文件名下载附件
工作簿1.rar
你说没有重复，其实是有重复的，所以，代码仅供参考

懒得想名字

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

会过去的

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

继成王者

规范表，然后透视即可

牵着白蛇念咒

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

孙海涛

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

猫崽

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

丞哥朱爸

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