c_c_lai

回復 1# Michelle-W
試試看！

1. Sub Ex()
   
2.     Dim lg As Variant, ctn As Variant, xi As Integer
   
3.     Dim dic As Object, sp As Variant, sh As Worksheet
   
4.    
   
5.     Set sh = Worksheets("05月")
   
6.     Set dic = CreateObject("scripting.dictionary")
   
7.    
   
8.     With sh
   
9.         For Each lg In .Range("B1:I1")
   
10.             .Select
    
11.             
    
12.             dic(lg.Value) = ""
    
13.             For Each ctn In .Range("A2:A7")
    
14.                 If ctn.Offset(, lg.Column - 1) = "V" Then
    
15.                     dic(lg.Value) = dic(lg.Value) + IIf(dic(lg.Value) = "", "", ",") + ctn.Value
    
16.                 End If
    
17.             Next
    
18.             sp = Split(dic(lg.Value), ",")
    
19.             '  Cells(15, lg.Column).Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))    '  展示用
    
20.             
    
21.             For xi = 1 To Worksheets.Count
    
22.                 If Worksheets(xi).Name = lg.Value Then Worksheets(xi).Select: Exit For
    
23.             Next xi
    
24.             If xi > Worksheets.Count Then
    
25.                  Sheets.Add After:=Sheets(Worksheets.Count)
    
26.                  ActiveSheet.Name = lg.Value
    
27.             End If
    
28.             With Worksheets(lg.Value)
    
29.                 .[A1] = sh.[A1]
    
30.                 .[B1] = lg.Value
    
31.                 .[A2].Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))
    
32.                 .[B2].Resize(UBound(sp) + 1) = "V"
    
33.             End With
    
34.         Next
    
35.     End With
    
36. End Sub

複製代碼

c_c_lai

回復 3# Michelle-W

下載 (55.19 KB)

2016-7-15 18:14

資料.rar (1.1 MB)

下載次數: 2

2016-7-15 18:15

c_c_lai

回復 8# Michelle-W
請參考！

下載 (49.64 KB)

2016-7-18 20:31

下載 (54.83 KB)

2016-7-18 20:31

下載 (45.38 KB)

2016-7-18 20:32

下載 (33.32 KB)

2016-7-18 20:32

各自分類資料.rar (33.09 KB)

下載次數: 5

2016-7-18 20:33

c_c_lai

回復 8# Michelle-W

1. Sub 各自分類()
   
2.     Dim lg As Variant, ctn As Variant, xi As Boolean
   
3.     Dim dic As Object, sp As Variant
   
4.     Dim sh As Worksheet, wks As Worksheet
   
5.    
   
6.     Set sh = Worksheets("選單")
   
7.     Set dic = CreateObject("scripting.dictionary")
   
8.    
   
9.     With sh
   
10.         For Each lg In .Range("C1", .Range("C1").End(xlToRight))
    
11.             .Select
    
12.             
    
13.             dic(lg.Value) = ""
    
14.             For Each ctn In .Range("A2", Range("A2").End(xlDown))
    
15.                 If ctn.Offset(, lg.Column - 1) = "V" Then
    
16.                     dic(lg.Value) = dic(lg.Value) + IIf(dic(lg.Value) = "", "", ",") + ctn.Value
    
17.                 End If
    
18.             Next
    
19.             If dic(lg.Value) <> "" Then
    
20.                sp = Split(dic(lg.Value), ",")
    
21.                 Cells(15, lg.Column).Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))    '  展示用
    
22.                
    
23.                 xi = tblExist(lg.Value)      '  判斷表單是否存在
    
24.                 If xi = False Then
    
25.                     Sheets.Add After:=Sheets(Worksheets.Count)
    
26.                     ActiveSheet.Name = lg.Value
    
27.                 End If
    
28.                
    
29.                 With Worksheets(lg.Value)
    
30.                     .Cells.Clear
    
31.                     .[A1] = sh.[A1]
    
32.                     .[B1] = lg.Value
    
33.                     .[A2].Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))
    
34.                     .[B2].Resize(UBound(sp) + 1) = "V"
    
35.                 End With
    
36.             End If
    
37.         Next
    
38.     End With
    
39. End Sub
    
40. 
    
41. Sub 新增選單()
    
42.     Dim rng As Range, rng2 As Range
    
43.    
    
44.     刪除工作表
    
45.     With Worksheets("選單")
    
46.         .Cells.Clear
    
47.         Set rng = Sheets("總表").Range("A2", Sheets("總表").[A2].End(xlDown))
    
48.         .[C1].Resize(, rng.Count - 1) = Application.Transpose(rng)
    
49.         Set rng = Sheets("總表").Range("A16", Sheets("總表").[B16].End(xlDown))
    
50.         rng.Copy .[A1]
    
51.     End With
    
52. End Sub
    
53. 
    
54. Function tblExist(tblName As String) As Boolean
    
55.     Dim xi As Integer
    
56.    
    
57.     tblExist = False
    
58.     For xi = 1 To Worksheets.Count
    
59.         If Worksheets(xi).Name = tblName Then tblExist = True: Exit Function
    
60.     Next xi
    
61. End Function
    
62. 
    
63. Sub 刪除工作表()
    
64.     Dim xi As Integer
    
65.    
    
66.     Application.DisplayAlerts = False
    
67.     For xi = Worksheets.Count To 2 Step -1
    
68.         If Worksheets(xi).Name <> "總表" And Worksheets(xi).Name <> "選單" Then
    
69.             Worksheets(xi).Delete
    
70.         End If
    
71.     Next xi
    
72.     Application.DisplayAlerts = True
    
73. End Sub
    
74. 
    
75. Sub 刪除各分頁()
    
76.     刪除工作表
    
77.     With Worksheets("選單")
    
78.         .Range("C2:" & Chr(64 + .[C1].End(xlToRight).Column) & 65535).Clear
    
79.     End With
    
80. End Sub

複製代碼

c_c_lai

回復 8# Michelle-W
我有點好奇你想像之整體作業的流程實際是如何進行的？
如果同時有5月與6月的資料要新增進去專屬工作表內，
又是怎說？

c_c_lai

回復 12# Michelle-W

下載 (68.79 KB)

2016-7-19 10:56

c_c_lai

回復 14# Michelle-W
是不是這樣？
各自分類資料.rar (30.73 KB)

下載次數: 8

2016-7-19 13:05

下載 (62.91 KB)

2016-7-19 13:12