- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
14#
發表於 2014-10-28 10:01
| 只看該作者
回復 13# j88141
多加一字典物件- Dim D(1 To 2) As Object
- Private Sub Ex() 'Excel檔案(檔案2),加入一個CommandButton 的程式碼
- Dim SH As Worksheet, Rng As Range, i As Integer
- Dictionary_Ex '執行這個程序
- For Each SH In Sheets 'Sheets :Excel檔案(檔案2)中的工作表集合
- Set Rng = SH.[A3] '編號
- Do While Rng <> ""
- For i = 4 To SH.UsedRange.Columns.Count
- If D(1).exists(SH.Cells(2, i) & Rng & SH.[A1]) Then '字典物件中有這 key 值
- 'key 值-> 星期 & 編號 & 地名
- '星期: Sh.Cells(2,i)
- '編號: Rng
- '地名" SH.[A1]
- D(1)(SH.Cells(2, i) & Rng & SH.[A1]).Copy Rng.Cells(1, i).Resize(4)
- Rng.Cells(1, i).Range("a3") = D(2)(SH.Cells(2, i) & Rng & SH.[A1])
- Else
- Rng.Cells(1, i).Resize(4) = ""
- End If
- Next
- Set Rng = Rng.End(xlDown) '下一個星期的位置
- Loop
- Next
- End Sub
- Private Sub Dictionary_Ex()
- Dim Rng(1 To 3) As Range, i As Integer, a
- Set D(1) = CreateObject("SCRIPTING.DICTIONARY")
- Set D(2) = CreateObject("SCRIPTING.DICTIONARY")
- With Workbooks("檔案1.xlsx").Sheets("工作表1") '原始資料檔案必須是開啟的
- Set Rng(1) = .[A4] '星期
- Do While Rng(1) <> ""
- Set Rng(2) = Rng(1).Offset(, 1) '編號
- Do While Not Intersect(Rng(1).MergeArea, Rng(2).Offset(, -1)) Is Nothing
-
- For i = 4 To .UsedRange.Columns.Count
- If Rng(2).Cells(1, i) <> "" Then '
- Set D(1)(Rng(1) & Rng(2) & Rng(2).Cells(3, i)) = Rng(2).Cells(1, i).Resize(4)
- D(2)(Rng(1) & Rng(2) & Rng(2).Cells(3, i)) = .Cells(3, Rng(2).Cells(1, i).Column)
- End If
- Next
- Set Rng(2) = Rng(2).End(xlDown) '下一個編號的位置
- Loop
- Set Rng(1) = Rng(1).End(xlDown) '下一個星期的位置
- Loop
- End With
- End Sub
|
|
發表於 2014-10-27 22:07
| 
