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

Option Explicit
Dim D As Object
Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range)
Dim Rng As Range
Application.EnableEvents = False
If Target.Address = "$A$1" Then
Dictionary_Ex
Set Rng = Sh.[A2]
Do While Rng <> ""
If D.exists((Rng & Target)) Then '字典物件中有這 key 值
D(Rng & Target).Copy Rng.Offset(, 1).Resize(3)
Else
Rng.Offset(, 1).Resize(3) = ""
End If
Set Rng = Rng.Offset(, 2) '向左移動2欄
Loop
End If
Application.EnableEvents = True
End Sub
Private Sub Dictionary_Ex()
Dim Rng(1 To 2) As Range, i As Integer, a
Set D = CreateObject("SCRIPTING.DICTIONARY")
With Workbooks("Xl0000001.xls").Sheets("工作表1") '原始資料檔案必須是開啟的
Set Rng(1) = .[A1] 'A欄的星期是合併3列的儲存格
Do While Rng(1) <> ""
Set Rng(2) = Rng(1).CurrentRegion.Rows(Rng(1).Row & ":" & Rng(1).Row + 2)
'CurrentRegion 屬性傳回 Range 物件，該物件代表目前的區域。目前區域是指以任意空白列及空白欄的組合為邊界的範圍。唯讀
'Rng(1).Row + 2 : Rng(1)所在的列號+ 2
For i = 2 To Rng(2).Columns.Count '星期的欄位從第2欄開始到最後一欄
Set D(Rng(1) & Rng(2).Cells(3, i)) = Rng(2).Columns(i)
'Rng(1) :星期 , Rng(2).Cells(3, i) :地名
Next
Set Rng(1) = Rng(1).End(xlDown) '下一個星期的位置
Loop
End With
End Sub

複製代碼

Option Explicit
Dim D As Object
Private Sub Ex() 'Excel檔案(檔案2),加入一個CommandButton 的程式碼
Dim SH As Worksheet, Rng As Range
Dictionary_Ex '執行這個程序
For Each SH In Sheets 'Sheets :Excel檔案(檔案2)中的工作表集合
Set Rng = SH.[A2]
Do While Rng <> ""
If D.exists(Rng & SH.[A1]) Then '字典物件中有這 key 值
D(Rng & SH.[A1]).Copy Rng.Offset(, 1).Resize(3)
Else
Rng.Offset(, 1).Resize(3) = ""
End If
Set Rng = Rng.Offset(, 2) '向左移動2欄
Loop
Next
End Sub

複製代碼

Option Explicit
Dim D 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.exists(SH.Cells(2, i) & Rng & SH.[A1]) Then '字典物件中有這 key 值
'key 值-> 星期 & 編號 & 地名
'星期: Sh.Cells(2,i)
'編號: Rng
'地名" SH.[A1]
D(SH.Cells(2, i) & Rng & SH.[A1]).Copy Rng.Cells(1, i).Resize(4)
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 = CreateObject("SCRIPTING.DICTIONARY")
With Workbooks("Xl0000001.xls").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 - 1
If Rng(2).Cells(1, i) <> "" Then '
Set D(Rng(1) & Rng(2) & Rng(2).Cells(3, i)) = Rng(2).Cells(1, i).Resize(4)
'地名: Rng(2).Cells(3, i)
End If
Next
Set Rng(2) = Rng(2).End(xlDown) '下一個編號的位置
Loop
Set Rng(1) = Rng(1).End(xlDown) '下一個星期的位置
Loop
End With
End Sub

複製代碼

如果我想要把檔案二的"地區" 改成輸入檔案一的 "符號"
也就是從E3開始算起的A、B、C等

複製代碼

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

複製代碼