stillfish00

回復 1# missbb
執行前只有data工作表

1. Sub Test()
   
2.   Dim i As Long, bAlert As Boolean
   
3.   Dim sName As String, sDept As String, sPost As String
   
4.   Dim wsTemp As Worksheet
   
5.   
   
6.   '先建立暫時的工作表範本，供之後Copy
   
7.   Set wsTemp = Sheets.Add(After:=Sheets(Sheets.Count))
   
8.   With wsTemp
   
9.     .Cells(1, 1).Value = "Name"
   
10.     .Cells(2, 1).Value = "Dept"
    
11.     .Cells(1, 5).Value = "Post"
    
12.     With .Cells(4, 1)
    
13.       .Resize(1, 4).Value = Array("Record", "In", "Out", "Remarks")
    
14.       .Resize(5, 4).Borders.LineStyle = xlContinuous
    
15.     End With
    
16.   End With
    
17.   
    
18.   '對 data 中項目建立各分頁
    
19.   With Sheets("data")
    
20.     For i = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
    
21.       sName = .Cells(i, 1).Value
    
22.       sDept = .Cells(i, 2).Value
    
23.       sPost = .Cells(i, 3).Value
    
24. 
    
25.       wsTemp.Copy After:=Sheets(Sheets.Count)
    
26.       With Sheets(Sheets.Count)
    
27.         .Name = sName
    
28.         .Cells(1, 2).Value = sName
    
29.         .Cells(2, 2).Value = sDept
    
30.         .Cells(1, 6).Value = sPost
    
31.       End With
    
32.     Next
    
33.   End With
    
34.   
    
35.   bAlert = Application.DisplayAlerts
    
36.   Application.DisplayAlerts = False
    
37.   wsTemp.Delete
    
38.   Application.DisplayAlerts = bAlert
    
39.   
    
40. End Sub

複製代碼