依照人名或者编号分别创建单独的工作表

mcvany

求高手前辈们帮帮忙，表格表头一致，但要按照其中的人名或者员工编号创建各自单独的工作表，并生成各自表的总计。格式还要一样，就像附件中其他的工作表那样。这个只有9个人，还能粘贴复制，如果数量大一点的话怎么弄呢？求大神助力。

jsqb

字典+数组可以解决

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   With Worksheets("9人")
   
9.     AutoFilterMode = False
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("c1:c" & r)
    
12.     For i = 5 To UBound(arr)
    
13.       If Len(arr(i, 1)) <> 0 Then
    
14.         If Not d.exists(arr(i, 1)) Then
    
15.           Set d(arr(i, 1)) = .Range("a1:k4")
    
16.         End If
    
17.         Set d(arr(i, 1)) = Union(d(arr(i, 1)), .Cells(i, 1).Resize(1, 11))
    
18.       End If
    
19.     Next
    
20.   End With
    
21.   For Each aa In d.keys
    
22.     On Error Resume Next
    
23.     Set ws = Worksheets(aa)
    
24.     If Err Then
    
25.       Set ws = Worksheets.Add(after:=Worksheets(Worksheets.Count))
    
26.       ws.Name = aa
    
27.     End If
    
28.     With Worksheets(aa)
    
29.       .Cells.Clear
    
30.       d(aa).Copy .Range("a1")
    
31.     End With
    
32.   Next
    
33. End Sub
    

复制代码

chxw68

详见附件。

abc123281

代码仅供测试参考



按人名分类成单独工作表123.rar (31.1 KB, 下载次数: 12)

2018-8-28 15:51 上传

点击文件名下载附件

BenjaminToo

Sub test2()
Dim arr1, arr2, dic
Dim i&, j&, k&, l&, sh As Worksheet, start As Double

Application.ScreenUpdating = False

start = Timer

Set dic = CreateObject("scripting.dictionary")

arr1 = Range("A4").CurrentRegion

j = 1

For i = 5 To UBound(arr1)

If Not dic.exists(arr1(i, 3)) And arr1(i, 3) <> "" Then



dic(arr1(i, 3)) = arr1(i, 3)

Set sh = Worksheets.Add(after:=ActiveSheet)

sh.Name = arr1(i, 3)

Worksheets(arr1(i, 3)).Range("A1:K1") = Application.Index(arr1, 1, 0)

Worksheets(arr1(i, 3)).Range("A2:K2") = Application.Index(arr1, 2, 0)

Worksheets(arr1(i, 3)).Range("A3:K3") = Application.Index(arr1, 3, 0)

Worksheets(arr1(i, 3)).Range("A4:K4") = Application.Index(arr1, 4, 0)

ActiveSheet.Range("A5:K5") = Application.Index(arr1, i, 0)

Else

If arr1(i, 3) <> "" Then

Worksheets(arr1(i, 3)).Range("A" & Range("A1048576").End(xlUp).Row + 1).Resize(1, 11).Value = Application.Index(arr1, i, 0)



End If



End If

Next

Worksheets(1).Range("A5").CurrentRegion.Copy

For Each sh In Worksheets

If sh.Index <> 1 Then

l = sh.Range("A1048576").End(xlUp).Row + 1

sh.Range("A" & l) = "合计"

sh.Range("D" & l) = Application.WorksheetFunction.Sum(sh.Range("D5:D" & l - 1))

sh.Range("E" & l) = Application.WorksheetFunction.Sum(sh.Range("E5:E" & l - 1))

sh.Range("F" & l) = Application.WorksheetFunction.Sum(sh.Range("F5:F" & l - 1))

sh.Range("G" & l) = Application.WorksheetFunction.Sum(sh.Range("G5:G" & l - 1))

sh.Range("H" & l) = Application.WorksheetFunction.Sum(sh.Range("H5:H" & l - 1))

sh.Range("I" & l) = Application.WorksheetFunction.Sum(sh.Range("I5:I" & l - 1))

sh.Range("J" & l) = Application.WorksheetFunction.Sum(sh.Range("J5:J" & l - 1))

sh.UsedRange.PasteSpecial xlPasteFormats

End If

Next

Application.ScreenUpdating = True

MsgBox "用时：" & Format(Timer - start, "0.00") & "秒。"

End Sub

mcvany

chxw68 发表于 2018-8-28 15:28
详见附件。

感谢前辈分享

729211ying

Sub ss()
Set cc = Worksheets.Add(after:=Worksheets("9人"))
Worksheets("9人").Range("a1:k4").Copy cc.Cells(1, 1)
cc.Name = "小一"
Worksheets(1).Activate
aa = Cells(Rows.Count, 3).End(xlUp).Row
j = 2
m = 5
For i = 5 To aa
    a = 0
    If Cells(i + 1, 3) = Cells(i, 3) Then
       Cells(i, 1).Resize(1, 11).Copy Worksheets(j).Cells(m, 1)
       m = m + 1
       a = a + 1
    End If
    If Cells(i + 1, 3) = "" Then
       Cells(i, 1).Resize(1, 11).Copy Worksheets(j).Cells(m, 1)
    Exit For
    End If
    If a = 0 Then
       Cells(i, 1).Resize(1, 11).Copy Worksheets(j).Cells(m, 1)
       Set bb = Worksheets.Add(after:=Worksheets(Worksheets.Count))
       bb.Name = Cells(i + 1, 3)
       Worksheets("9人").Range("a1:k4").Copy bb.Cells(1, 1)
       j = j + 1
       m = 5
    End If
Next
End Sub

729211ying

感觉用数组和字典反而麻烦哈哈

jiminyanyan

关注一下。。。