- 帖子
- 4901
- 主題
- 44
- 精華
- 24
- 積分
- 4916
- 點名
- 142
- 作業系統
- Windows 7
- 軟體版本
- Office 20xx
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台北
- 註冊時間
- 2010-4-30
- 最後登錄
- 2026-7-16
                
|
2#
發表於 2019-1-15 16:05
| 只看該作者
回復 1# tsuan - Sub 分類()
- Dim A As Range, Ay()
- Set Sht = CreateObject("Scripting.Dictionary")
- Set dic = CreateObject("Scripting.Dictionary")
- With Sheets("總表")
- For Each A In .Range(.[A2], .[A2].End(xlDown))
- For i = 5 To 9
- ar = Array(A.Offset(, 1), A.Offset(, 2), A.Offset(, 3), .Cells(A.Row, i).Value)
- If IsEmpty(dic(A & " " & .Cells(1, i))) Then
- ReDim Preserve Ay(1)
- Ay(0) = Array("貨號", "貨品描述", "單位", "價格") '標題列
- Ay(1) = ar '資料列
- dic(A & " " & .Cells(1, i)) = Ay '暫存於字典物件中
- Else
- Ay = dic(A & " " & .Cells(1, i)) '讀出字典內容
- s = UBound(Ay)
- ReDim Preserve Ay(s + 1)
- Ay(s + 1) = ar '加入資料列
- dic(A & " " & .Cells(1, i)) = Ay '暫存於字典物件中
- End If
- Next
- Next
- End With
- For Each sh In Sheets '讀取所有工作表名稱
- Sht(sh.Name) = sh.Name
- Next
- For Each ky In dic.keys
- If Not Sht.exists(ky) Then '若工作表不存在
- With Worksheets.Add(after:=Sheets(Sheets.Count)) '新增工作表
- .Name = ky
- End With
- End If
- With Sheets(ky) '寫入工作表資料
- .[B1] = "館別:"
- .[D1] = "廠商:"
- .[C1] = Split(ky, " ")(0)
- .[E1] = Split(ky, " ")(1)
- .[A3].Resize(UBound(dic(ky)) + 1, 4) = Application.Transpose(Application.Transpose(dic(ky)))
- End With
- Next
- End Sub
|
|
發表於 2019-1-16 16:19
| 
