[發問] 如何自行判斷並填入

j88141

請問在原始資料中(檔案1)有五個地名

下載 (19.09 KB)

2014-4-22 21:14

然後想要用VBA判斷並自動填入到另一個excel檔案(檔案2)
像下列這樣

下載 (28.62 KB)

2014-4-22 21:12

請問有辦法嗎
檔案1+2.rar (16.47 KB)

下載次數: 13

2014-4-22 21:13

GBKEE

回復 1# j88141

自動填入到另一個excel檔案(檔案2)的ThisWorkbook程式碼

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

複製代碼

j88141

回復 2# GBKEE


輸入之後怎麼會出現編譯錯誤
Dictionary_Ex
這一個沒有定義sub或 function

j88141

回復 3# j88141


GBKEE老師

我還有一個問題
就是在資料2的A1 不是有地名嗎
可是好像要重新輸入 才會觸發VBA
請問該怎麼修改
或是加入一個CommandButton呢

GBKEE

回復 4# j88141

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

複製代碼

j88141

回復 5# GBKEE


    GBKEE 老師

如果 我想把 地名 改變  如  原始資料金門改成台北

但在檔案二 好像 還是會自動搜尋金門  然後填入

我這兩天 查了 dictionary 這物件  
知道 要用d.RemoveAll 來清除字典中的數據
但卻不知道如何加入

順便一問  看不太懂這一句...
Set Rng(2) = Rng(1).CurrentRegion.Rows(Rng(1).Row & ":" & Rng(1).Row + 2)

謝謝GBKEE 老師

GBKEE

回復 6# j88141
2# ,5# 的程式碼都更新,可再看一次

j88141

回復 7# GBKEE
     GBKEE 老師   

這是我想出來的
因為一開始的 只有一個符合項目  就可以填入檔案2中

那如果需要符合 兩個項目 才可以填進
那程式碼需要怎麼改才行

下載 (41.63 KB)

2014-4-28 22:27

下載 (34.05 KB)

2014-4-28 22:27

檔案1+2(new).rar (29.82 KB)

下載次數: 9

2014-4-28 22:29

GBKEE

回復 8# j88141

兩檔案的"中午" 這字串要一致

1. Option Explicit
   
2. Dim D As Object
   
3. Private Sub Ex()  'Excel檔案(檔案2),加入一個CommandButton 的程式碼
   
4.     Dim SH As Worksheet, Rng As Range, i As Integer
   
5.     Dictionary_Ex               '執行這個程序
   
6.     For Each SH In Sheets       'Sheets :Excel檔案(檔案2)中的工作表集合
   
7.         Set Rng = SH.[A3]       '編號
   
8.         Do While Rng <> ""
   
9.             For i = 4 To SH.UsedRange.Columns.Count
   
10.                 If D.exists(SH.Cells(2, i) & Rng & SH.[A1]) Then '字典物件中有這 key 值
    
11.                     'key 值-> 星期 & 編號 & 地名
    
12.                     '星期: Sh.Cells(2,i)
    
13.                     '編號: Rng
    
14.                     '地名" SH.[A1]
    
15.                     D(SH.Cells(2, i) & Rng & SH.[A1]).Copy Rng.Cells(1, i).Resize(4)
    
16.                 Else
    
17.                     Rng.Cells(1, i).Resize(4) = ""
    
18.                 End If
    
19.             Next
    
20.             Set Rng = Rng.End(xlDown) '下一個星期的位置
    
21.         Loop
    
22.     Next
    
23. End Sub
    
24. Private Sub Dictionary_Ex()
    
25.     Dim Rng(1 To 3) As Range, i As Integer, a
    
26.     Set D = CreateObject("SCRIPTING.DICTIONARY")
    
27.     With Workbooks("Xl0000001.xls").Sheets("工作表1")   '原始資料檔案必須是開啟的
    
28.         Set Rng(1) = .[A4]                              '星期
    
29.         Do While Rng(1) <> ""
    
30.             Set Rng(2) = Rng(1).Offset(, 1)             '編號
    
31.             Do While Not Intersect(Rng(1).MergeArea, Rng(2).Offset(, -1)) Is Nothing
    
32.                 For i = 4 To .UsedRange.Columns.Count - 1
    
33.                   If Rng(2).Cells(1, i) <> "" Then     '
    
34.                         Set D(Rng(1) & Rng(2) & Rng(2).Cells(3, i)) = Rng(2).Cells(1, i).Resize(4)
    
35.                                                         '地名: Rng(2).Cells(3, i)
    
36.                     End If
    
37.                 Next
    
38.                 Set Rng(2) = Rng(2).End(xlDown)         '下一個編號的位置
    
39.             Loop
    
40.             Set Rng(1) = Rng(1).End(xlDown)             '下一個星期的位置
    
41.        Loop
    
42.      End With
    
43. End Sub

複製代碼

j88141

回復 9# GBKEE


    謝謝GBKEE 老師   
  我學到很多