拆分表格求助

泓丶

表内有发货单维护sheet 需要大家大家帮助 根据A列人名 按人名分sheet拆表 每个分sheet以该人名重命名
拆分后每个表内 列求和为0时 该列删除 。
谢谢大家

rysxing

拆分后的表内容？以及重名如何处理？表述不清楚帮不上

泓丶

rysxing 发表于 2024-8-23 16:20
拆分后的表内容？以及重名如何处理？表述不清楚帮不上

根据人名拆分表后  每个Sheet按该拆分人名命名 表内只留拆分该人名内容
每个拆分sheet 从E列纵向求和为0的 删除该列

小凡、、、

参与一下，拆分

rysxing

试试，不知道是不是你要的效果。

ykcbf1100

参与一下。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()   '//2024.8.23
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Set sh = ThisWorkbook.Sheets("发货单维护")
   
6.     With sh
   
7.         r = .Cells(Rows.Count, 1).End(3).Row
   
8.         arr = .[a1].Resize(r, 38)
   
9.     End With
   
10.     For i = 6 To r
    
11.         s = arr(i, 1)
    
12.         d(s) = ""
    
13.     Next
    
14.     On Error Resume Next
    
15.     For Each k In d.keys
    
16.         sh.Copy After:=Sheets(Sheets.Count)
    
17.         Set sht = Sheets(Sheets.Count)
    
18.         m = 0
    
19.         ReDim brr(1 To 10000, 1 To UBound(arr, 2))
    
20.         With sht
    
21.             .Name = k
    
22.             .DrawingObjects.Delete
    
23.             For i = 6 To UBound(arr)
    
24.                 If arr(i, 1) = k Then
    
25.                     m = m + 1
    
26.                     For j = 1 To UBound(arr, 2)
    
27.                         brr(m, j) = arr(i, j)
    
28.                     Next
    
29.                 End If
    
30.             Next
    
31.             .[a6].Resize(m, UBound(arr, 2)) = brr
    
32.             .Cells(5 + m, 1).Resize(10000, UBound(arr, 2)).Clear
    
33.             Sum = 0
    
34.             For i = 6 To m + 5
    
35.                 Sum = Sum + Val(.Cells(i, 5))
    
36.             Next
    
37.             If Sum = 0 Then .Columns("e:e").Delete
    
38.         End With
    
39.     Next
    
40.     Set d = Nothing
    
41.     Application.ScreenUpdating = True
    
42.     MsgBox "OK！"
    
43. End Sub
    

复制代码

usedrange

1. Sub tt()
   
2.     Dim ar, sh, i%, j%, head, dic, r, s, k
   
3.     Set dic = CreateObject("scripting.dictionary")
   
4.     Application.ScreenUpdating = False
   
5.     With Sheets("发货单维护")
   
6.         ar = .UsedRange
   
7.         Set head = .Range("a1:al5")
   
8.         For i = 6 To UBound(ar)
   
9.             If ar(i, 1) <> "" And Not dic.exists(ar(i, 1)) Then
   
10.                 dic(ar(i, 1)) = ""
    
11.                 Set sh = Sheets.Add
    
12.                 sh.Name = ar(i, 1)
    
13.                 head.Copy [a1].Resize(5, 38)
    
14.                 r = [a104800].End(xlUp).Row + 1
    
15.                 For j = 1 To UBound(ar, 2)
    
16.                     If Not WorksheetFunction.IsNA(ar(i, j)) Then
    
17.                         If ar(i, j) <> "" Then Sheets(ar(i, 1)).Cells(r, j) = ar(i, j)
    
18.                     End If
    
19.                 Next j
    
20.             ElseIf dic.exists(ar(i, 1)) Then
    
21.                 Sheets(ar(i, 1)).Activate
    
22.                 r = [a104800].End(xlUp).Row + 1
    
23.                 For j = 1 To UBound(ar, 2)
    
24.                     If Not WorksheetFunction.IsNA(ar(i, j)) Then
    
25.                         If ar(i, j) <> "" Then Sheets(ar(i, 1)).Cells(r, j) = ar(i, j)
    
26.                     End If
    
27.                 Next j
    
28.             End If
    
29.         Next i
    
30.         For Each k In Sheets
    
31.             If k.Index < 9 Then
    
32.                 Sheets(k.Name).Activate
    
33.                 m = [a1048000].End(xlUp).Row - 5
    
34.                 For i = 38 To 5 Step -1
    
35.                     Set s = Cells(6, i).Resize(m, 1)
    
36.                     If WorksheetFunction.Sum(s) = 0 Then
    
37.                         Columns(i).Delete
    
38.                     End If
    
39.                 Next i
    
40.             End If
    
41.         Next k
    
42.         Set s = Nothing
    
43.     End With
    
44.     Set head = Nothing
    
45.     Set dic = Nothing
    
46.     Set s = Nothing
    
47.     Application.ScreenUpdating = True
    
48. End Sub
    
49. 
    

复制代码

泓丶

ykcbf1100 发表于 2024-8-23 18:19
参与一下。。。

        谢谢