12
返回列表 上一主題 發帖

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

j88141

帖子
46 
主題
10 
精華
0 
積分
88 
點名
0  
作業系統
WIN10 
軟體版本
excel2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2014-1-27 
最後登錄
2018-3-30 
1# 跳轉到 » 倒序看帖
打印
tT
發表於 2014-4-22 21:14 | 只看該作者

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

本帖最後由 j88141 於 2014-4-22 21:15 編輯

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

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


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

檔案1和2.rar (16.47 KB)

收藏 分享

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
2#
發表於 2014-4-23 06:17 | 只看該作者
本帖最後由 GBKEE 於 2014-4-27 05:56 編輯

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

j88141

帖子
46 
主題
10 
精華
0 
積分
88 
點名
0  
作業系統
WIN10 
軟體版本
excel2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2014-1-27 
最後登錄
2018-3-30 
3#
發表於 2014-4-23 12:46 | 只看該作者
回復 2# GBKEE


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

TOP

j88141

帖子
46 
主題
10 
精華
0 
積分
88 
點名
0  
作業系統
WIN10 
軟體版本
excel2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2014-1-27 
最後登錄
2018-3-30 
4#
發表於 2014-4-23 21:11 | 只看該作者
回復 3# j88141


GBKEE老師

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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
5#
發表於 2014-4-24 04:57 | 只看該作者
本帖最後由 GBKEE 於 2014-4-27 06:04 編輯

回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

j88141

帖子
46 
主題
10 
精華
0 
積分
88 
點名
0  
作業系統
WIN10 
軟體版本
excel2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2014-1-27 
最後登錄
2018-3-30 
6#
發表於 2014-4-27 00:33 | 只看該作者
回復 5# GBKEE


    GBKEE 老師

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

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

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

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

謝謝GBKEE 老師

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
7#
發表於 2014-4-27 06:05 | 只看該作者
回復 6# j88141
2# ,5# 的程式碼都更新,可再看一次
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

j88141

帖子
46 
主題
10 
精華
0 
積分
88 
點名
0  
作業系統
WIN10 
軟體版本
excel2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2014-1-27 
最後登錄
2018-3-30 
8#
發表於 2014-4-28 22:29 | 只看該作者
回復 7# GBKEE
     GBKEE 老師   

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

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



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

TOP

GBKEE

帖子
5923 
主題
13 
精華
1 
積分
5986 
點名
0  
作業系統
win10 
軟體版本
Office 2010 
閱讀權限
150 
性別
男 
來自
台灣基隆 
註冊時間
2010-5-1 
最後登錄
2022-1-23 

2017 雞年全勤獎章2016猴年全勤獎章2015羊年全勤獎章2014馬年全勤獎章2013蛇年全勤獎章2012龍年全勤獎章論壇貢獻勳章熱烈參與勳章2011兔年全勤獎章
9#
發表於 2014-4-29 07:04 | 只看該作者
回復 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
複製代碼
感恩的心......(在麻辣家族討論區.用心學習會有進步的)
但資源無限,後援有限,  一天1元的贊助,人人有能力.

TOP

j88141

帖子
46 
主題
10 
精華
0 
積分
88 
點名
0  
作業系統
WIN10 
軟體版本
excel2016 
閱讀權限
20 
性別
男 
來自
台灣 
註冊時間
2014-1-27 
最後登錄
2018-3-30 
10#
發表於 2014-5-1 00:43 | 只看該作者
回復 9# GBKEE


    謝謝GBKEE 老師   
  我學到很多

TOP

        靜思自在 : 心中常存善解、包容、感思、知足、惜福。
12
返回列表 上一主題