麻辣家族討論版版 - Powered by Discuz! Board

Sub Ex()
Dim lg As Variant, ctn As Variant, xi As Integer
Dim dic As Object, sp As Variant, sh As Worksheet
Set sh = Worksheets("05月")
Set dic = CreateObject("scripting.dictionary")
With sh
For Each lg In .Range("B1:I1")
.Select
dic(lg.Value) = ""
For Each ctn In .Range("A2:A7")
If ctn.Offset(, lg.Column - 1) = "V" Then
dic(lg.Value) = dic(lg.Value) + IIf(dic(lg.Value) = "", "", ",") + ctn.Value
End If
Next
sp = Split(dic(lg.Value), ",")
' Cells(15, lg.Column).Resize(UBound(sp) + 1) = Application.Transpose(Array(sp)) ' 展示用
For xi = 1 To Worksheets.Count
If Worksheets(xi).Name = lg.Value Then Worksheets(xi).Select: Exit For
Next xi
If xi > Worksheets.Count Then
Sheets.Add After:=Sheets(Worksheets.Count)
ActiveSheet.Name = lg.Value
End If
With Worksheets(lg.Value)
.[A1] = sh.[A1]
.[B1] = lg.Value
.[A2].Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))
.[B2].Resize(UBound(sp) + 1) = "V"
End With
Next
End With
End Sub

複製代碼

Sub 各自分類()
Dim lg As Variant, ctn As Variant, xi As Boolean
Dim dic As Object, sp As Variant
Dim sh As Worksheet, wks As Worksheet
Set sh = Worksheets("選單")
Set dic = CreateObject("scripting.dictionary")
With sh
For Each lg In .Range("C1", .Range("C1").End(xlToRight))
.Select
dic(lg.Value) = ""
For Each ctn In .Range("A2", Range("A2").End(xlDown))
If ctn.Offset(, lg.Column - 1) = "V" Then
dic(lg.Value) = dic(lg.Value) + IIf(dic(lg.Value) = "", "", ",") + ctn.Value
End If
Next
If dic(lg.Value) <> "" Then
sp = Split(dic(lg.Value), ",")
Cells(15, lg.Column).Resize(UBound(sp) + 1) = Application.Transpose(Array(sp)) ' 展示用
xi = tblExist(lg.Value) ' 判斷表單是否存在
If xi = False Then
Sheets.Add After:=Sheets(Worksheets.Count)
ActiveSheet.Name = lg.Value
End If
With Worksheets(lg.Value)
.Cells.Clear
.[A1] = sh.[A1]
.[B1] = lg.Value
.[A2].Resize(UBound(sp) + 1) = Application.Transpose(Array(sp))
.[B2].Resize(UBound(sp) + 1) = "V"
End With
End If
Next
End With
End Sub
Sub 新增選單()
Dim rng As Range, rng2 As Range
刪除工作表
With Worksheets("選單")
.Cells.Clear
Set rng = Sheets("總表").Range("A2", Sheets("總表").[A2].End(xlDown))
.[C1].Resize(, rng.Count - 1) = Application.Transpose(rng)
Set rng = Sheets("總表").Range("A16", Sheets("總表").[B16].End(xlDown))
rng.Copy .[A1]
End With
End Sub
Function tblExist(tblName As String) As Boolean
Dim xi As Integer
tblExist = False
For xi = 1 To Worksheets.Count
If Worksheets(xi).Name = tblName Then tblExist = True: Exit Function
Next xi
End Function
Sub 刪除工作表()
Dim xi As Integer
Application.DisplayAlerts = False
For xi = Worksheets.Count To 2 Step -1
If Worksheets(xi).Name <> "總表" And Worksheets(xi).Name <> "選單" Then
Worksheets(xi).Delete
End If
Next xi
Application.DisplayAlerts = True
End Sub
Sub 刪除各分頁()
刪除工作表
With Worksheets("選單")
.Range("C2:" & Chr(64 + .[C1].End(xlToRight).Column) & 65535).Clear
End With
End Sub

複製代碼