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

標題: [發問] 搜尋符合條件的訂單號碼 [打印本頁]

作者: PJChen 時間: 2017-7-4 02:32 標題: 搜尋符合條件的訂單號碼

大大好,

在"除外工作表"k1有一個指定的訂單號碼(它會依需求而變動號碼)為依據,用來搜尋BOM,請購,領料...等工作表中符合此訂單號碼的就將全部料號依序排列出,請問什麼函數可以達成這個要求?
1) 其中BOM工作表F欄料號有時資料會空白,所以是有的話列出在除外工作表F欄位,沒有的話就空白,料號不能重複出現,並在F1標示總共有幾筆資料領料工作表(加總筆數要來自BOM工作表)
2) 請購,領料2個工作表的資料包含各種訂單號碼,所以料號是不會依訂單順序出現的
3) 請購工作表D欄符合訂單號碼的話,就將料號列在除外工作表G欄位,料號不能重複出現,並在g1標示總共有幾筆資料(加總筆數要來自請購工作表)
4) 領料工作表D欄符合訂單號碼的話,就將料號列在除外工作表J欄位,料號不能重複出現,並在j1標示總共有幾筆資料(加總筆數要來自領料工作表)
註:原本工作表中資料幾千筆,因為檔案太大刪除很多資料,所以可以看到的訂單資料沒有很多.
[attach]27425[/attach]

作者: PJChen 時間: 2017-7-10 00:52

我把問題再寫得明確一點,
1 當"VBA報表指令.xlsm"H2儲存格設定值是M2時
2 在來源資料檔"庫存資料表.xlsx"的D欄,找尋第一個出現的M2(在D11欄位)
3 copy來源資料檔"庫存資料表.xlsx"的第11列,從A11:AA的資料最底端 (這不能打上一個實際的儲存格範圍,因為資料會變動)
4 貼到目的檔"庫存.xlsx"的A11(相對位置是D欄第一筆出現的M2位置:在第11列)

請問有人會寫這樣的VBA嗎？ [attach]27453[/attach]

作者: Hsieh 時間: 2017-7-10 14:13

回復 2# PJChen

貼上的位置是庫存檔案的位置，若原來庫存的筆數不同該如何處理?
若筆數相同就會直接覆蓋原有資料，這是你的需求嗎?
若筆數教員資料多，則會影響不同準則的資料，這些跟庫存觀念好像都不符合

作者: PJChen 時間: 2017-7-10 18:14

回復 3# Hsieh

大大好,

我抓的報表日期區間可能就是當月份的,Excel檔中的資料會累積比較多資料,所以我在VBA報表指令.xlsm H2中指定一個單號名稱,而一個單號可能有很多筆,所以我要指定它可以從找到的第一筆開始貼上,這樣就不會蓋掉我需要的資料,同時也可以更新我要的資料.

只是我手上正好有這個資料,所以就偷懶用這個檔來詢問,不過觀念是相同的.

作者: Hsieh 時間: 2017-7-11 11:26

回復 4# PJChen

參考看看

Sub copy_all()
Dim ws() '已經開啟視窗
books = Array("庫存資料表.xlsx", "庫存.xlsx") '欲開啟檔案
mypath = ThisWorkbook.Path '存放檔案資料夾
For Each w In Windows '已經開啟視窗
ReDim Preserve ws(s)
ws(s) = w.Caption
s = s + 1
Next
For Each b In books '測試檔案是否開啟
If UBound(Filter(ws, b)) = -1 Then Workbooks.Open (mypath & "\" & b) '檔案未開啟則開啟
Next
x = ThisWorkbook.Sheets(1).[H2] '準則
With Workbooks(books(0)) '庫存資料表.xlsx
Set a = .Sheets(1).Columns("D").Find(x, lookat:=xlWhole) '找準則位置
If a Is Nothing Then MsgBox "找不到準則位置": End
k = Application.CountIf(a.EntireColumn, x) '合乎準則列數
Set Rng = .Sheets(1).Cells(a.Row, "B").Resize(k, 26) 'B:AA欄資料
With Workbooks(books(1)) '庫存.xlsx
k1 = Application.CountIf(.Sheets(1).Columns("D"), x) '合乎準則列數
Set a = .Sheets(1).Columns("D").Find(x, lookat:=xlWhole) '找準則位置
If a Is Nothing Then Set a = .Sheets(1).Cells(.Sheets(1).Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
yn = MsgBox("原資料" & k1 & "列，新資料" & k & "列，是否複製?", vbYesNo)
If yn = 6 Then
a.Offset(, -2).Resize(k, 26).Value = Rng.Value '寫入新資料
MsgBox "資料已更新"
Else
MsgBox "資料未更新", 48
End If
End With
End With
End Sub

複製代碼

作者: PJChen 時間: 2017-7-11 23:44

回復 5# Hsieh

大大,

我測試了幾次,發現一些問題,要再麻煩您修改下.

1. 在測試的時候,我故意把"庫存.xlsx"的資料刪除,只保留至1000列.
2. "庫存資料表"共1059列(都沒有刪除), 當我把"VBA報表指令.xlsm" H2的變數改為M1時,它應該要從"庫存資料表"的A1:AA1059複製到"庫存.xlsx"的A1:AA1059貼滿,但它只詢問有9列新資料是否要更新.
3. 當我把"庫存.xlsx"的資料A欄資料保留10列,其餘A11以後為空白時，它也無法正常更新資料

P.S. 大大寫的程式因為不是巨集式的,我有看沒有懂,您可否幫我註解再更詳細些，因為這個程式,我會應用到很多資料上，詳細的註解有助於我日後的小修改.
附上我測試的檔案 [attach]27458[/attach]

先謝謝了.

作者: Hsieh 時間: 2017-7-13 11:40

回復 6# PJChen

Sub copy_all()
Dim ws() '已經開啟視窗
books = Array("庫存資料表.xlsx", "庫存.xlsx") '欲開啟檔案
mypath = ThisWorkbook.Path '存放檔案資料夾
For Each w In Windows '已經開啟視窗
ReDim Preserve ws(s)
ws(s) = w.Caption
s = s + 1
Next
For Each b In books '測試檔案是否開啟
If UBound(Filter(ws, b)) = -1 Then Workbooks.Open (mypath & "\" & b) '檔案未開啟則開啟
Next
x = ThisWorkbook.Sheets(1).[H2] '準則
With Workbooks(books(0)).Sheets(1) '庫存資料表.xlsx
Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
If a Is Nothing Then MsgBox "找不到準則位置": End
Set Rng = .Range(a.Offset(, -2), a.End(xlDown).Offset(, 23)) 'B:AA欄資料
MsgBox Rng.Address
With Workbooks(books(1)).Sheets(1) '庫存.xlsx
Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
If a Is Nothing Then Set a = .Cells(.Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
.Range("A" & a.Row & ":AA" & .Rows.Count).ClearContents
a.Offset(, -2).Resize(Rng.Rows.Count, 26).Value = Rng.Value '寫入新資料
a.Offset(, -3).Resize(Rng.Rows.Count, 1) = Rng.Columns(5).Value '寫入A欄編號
MsgBox "資料已更新"
End With
End With
End Sub

複製代碼

作者: PJChen 時間: 2017-7-14 23:38

回復 7# Hsieh

大大,
1) 經測試,貼資料的時候,它會把AA欄的資料貼到A欄,然後其他資料向右移一個欄位....請問要如何修正?
2) 因為這個程式,我還會使用在其他的文件上，books = Array("庫存資料表.xlsx", "庫存.xlsx"),是否檔名不同時,我只要改不同顏色的檔名即可？其他檔名如程式中的Sheets(1)我不用動它,是嗎？
3) 當我的檔案存放路徑不同時,我需要修改什麼地方嗎？
4) 但每份報表的貼上位置不同,如果我要自己修改，以VBA報表指令.xlsm的VBA指令.sheet H2儲存格為搜尋準則去搜尋目的檔C欄,但是貼上要在B欄,我要怎麼修改?

不好意思,麻煩你了...

作者: PJChen 時間: 2017-7-15 23:55

回復 7# Hsieh
大大,
我修改了些小地方,現在貼上時正常了.

Sub copy_all()
Dim ws() '已經開啟視窗
books = Array("庫存資料表.xlsx", "庫存.xlsx") '欲開啟檔案
mypath = ThisWorkbook.Path '存放檔案資料夾
For Each W In Windows '已經開啟視窗
ReDim Preserve ws(s)
ws(s) = W.Caption
s = s + 1
Next
For Each b In books '測試檔案是否開啟
If UBound(Filter(ws, b)) = -1 Then Workbooks.Open (mypath & "\" & b) '檔案未開啟則開啟
Next
x = ThisWorkbook.Sheets(1).[H2] '準則
With Workbooks(books(0)).Sheets(1) '庫存資料表.xlsx
Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
If a Is Nothing Then MsgBox "找不到準則位置": End
Set Rng = .Range(a.Offset(, -3), a.End(xlDown).Offset(, 23)) 'B:AA欄資料
'MsgBox Rng.Address
With Workbooks(books(1)).Sheets(1) '庫存.xlsx
Set a = .Columns("D").Find(x, lookat:=xlWhole) '找準則位置
If a Is Nothing Then Set a = .Cells(.Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
.Range("A" & a.Row & ":AA" & .Rows.Count).ClearContents
a.Offset(, -3).Resize(Rng.Rows.Count, 27).Value = Rng.Value '寫入新資料
'a.Offset(, -3).Resize(Rng.Rows.Count, 1) = Rng.Columns(5).Value '寫入A欄編號
MsgBox "資料已更新"
End With
End With
End Sub

複製代碼

作者: PJChen 時間: 2017-7-16 01:06

回復 7# Hsieh

我自己修改了程式但沒有貼的動作,請問
Row.Count要如何數？Offset(1)又代表什麼？
還有第二行的程式要怎麼解讀？

If a Is Nothing Then Set a = .Cells(.Rows.Count, 4).End(xlUp).Offset(1) '原資料不存在準則資料
.Range("A" & a.Row & ":AA" & .Rows.Count).ClearContents

複製代碼

作者: PJChen 時間: 2017-7-16 14:54

回復 7# Hsieh

大大,

我想將你寫的這個程式套到以下這幾個模式中，目前只先嘗試"訂單明細表",但一直不成功！可否請你示範下如何修改程式內容？ [attach]27484[/attach]

來源檔 Q:\00_科毅\出貨文件連結\FromERP\
訂單明細表.xlsx
請購單明細表.xlsx
採購單明細表.xlsx
進貨單明細表.xlsx
領料單明細表.xlsx
出貨單明細表.xlsx

目的檔 Q:\00_科毅\出貨文件連結\ERP_Data.xlsx
訂單.sheet
請購.sheet
採購.sheet
進貨.sheet
領料.sheet
出貨.sheet

準則存放的檔案及儲存格
Q:\00_科毅\出貨文件連結\VBA報表指令.xlsm
訂單明細表 H2
請購單明細表 H3
採購單明細表 H4
進貨單明細表 H5
領料單明細表 H6
出貨單明細表 H7

訂單明細表的套表模式為：
1. 以VBA報表指令.xlsm H2為準則,搜尋訂單明細表的B2欄位,當符合H2時(目前的值是MSO17060001)
2. 目前符合的儲存格是B11,則copy B11~BA的資料最底端,如果找不到代表沒有資料可複製.
3. 貼上資料至目的檔 Q:\00_科毅\出貨文件連結\ERP_Data.xlsx的"訂單.sheet",符合B欄MSO17060001的位置,並直接覆蓋原資料,選擇性貼上值(不要更改原資料的格式),如果找不到時,就當成是最新的資料,直接從目的檔的B欄最底端下一欄的空白列貼上(所以要能自動偵測資料的最末端,如果有全列空白(非全列空白不算是空白),其空白的第一列(若有空白列後再出現的資料視同空白)即是貼新資料的地方.

注意事項:
1. 來源檔及目的檔的資料都來自系統Download的報表,所以資料多寡是會變動的
2. 準則存放的H2~H7,其值也會隨著需求而變動
3. 目的檔每個sheet都有設定組成群組,是否應有先打開群組的動作,資料才會貼正確位置？
4. 當資料貼完以後,要再隱藏群組

作者: GBKEE 時間: 2017-7-25 10:06

本帖最後由 GBKEE 於 2017-7-27 07:45 編輯

回復 11# PJChen
重新回到 11# 的問題
問題複雜可以一個一個來
**********************************
訂單明細表的套表模式為：
1. 以VBA報表指令.xlsm H2為準則,搜尋訂單明細表的B2欄位,當符合H2時(目前的值是MSO17060001)
2. 目前符合的儲存格是B11,則copy B11~BA的資料最底端,如果找不到代表沒有資料可複製.
3. 貼上資料至目的檔 Q:\00_科毅\出貨文件連結\ERP_Data.xlsx的"訂單.sheet",符合B欄MSO17060001的位置,並直接覆蓋原資料,選擇性貼上值(不要更改原資料的格式),如果找不到時,就當成是最新的資料,直接從目的檔的B欄最底端下一欄的空白列貼上(所以要能自動偵測資料的最末端,如果有全列空白(非全列空白不算是空白),其空白的第一列(若有空白列後再出現的資料視同空白)即是貼新資料的地方.
********************************

Option Explicit
Dim 目的檔 As Workbook, 來源檔 As Workbook
Dim 準則單號 As String, 準則單號_Rng As Range
Dim 欄位 As String, 工作頁 As String, Msg As String
Sub Main()
Dim Table As Range, Sh As Worksheet, i As Integer
Msg = ""
With ThisWorkbook.Sheets("VBA指令") '設定準則範圍
Set Table = .Range("G2", .Range("G2").End(xlDown)).Resize(, 2) '
End With
File_settings 目的檔, "ERP_Data.XLSX" '設定目的檔
For i = 1 To Table.Rows.Count
File_settings 來源檔, Table.Cells(i, 1) & ".XLSX" '設定來源檔
準則單號 = Table.Cells(i, 2) '讀取準則
工作頁 = Mid(Table.Cells(i, 1), 1, 2) '目的檔的工作表名稱
欄位 = IIf(工作頁 = "訂單" Or 工作頁 = "進貨" Or 工作頁 = "領料", "C:C", "B:B") '目的檔的工作表的欄位
xSearch
來源檔.Close False
Next
'******************************
'目的檔.Close True 暫時不存檔
'******************************
If Msg <> "" Then MsgBox Msg
End Sub
Private Sub xSearch()
Dim D As Object, M, 工作頁 As String
Set D = CreateObject("SCRIPTING.DICTIONARY") '字典物件
With 來源檔.Sheets(1) '.Range("b:b") '來源檔第一個工作表的B欄
.Cells.Sort .Range("B1"), 1, Header:=xlYes '排序
M = Application.Match(準則單號, .Range("b:b").Cells, 0)
'**********************************
If IsError(M) Then Exit Sub '來源檔沒有找到準則,離開這程式 (不處理)
'**找到準則,設定準則的資料範圍
With .Range("b:b")
Do While .Cells(M) = 準則單號
'.Range("B" & M & ":BA" & M) -> 共27欄
If TypeName(D(.Cells(M).Value)) <> "Range" Then
Set D(準則單號) = .Range("a" & M).Resize(, 27)
Else
Set D(準則單號) = Union(D(準則單號), .Range("a" & M).Resize(, 27))
End If
M = M + 1
Loop
End With
Set 準則單號_Rng = D(準則單號)
End With
目的檔_準則單號
End Sub
Private Sub 目的檔_準則單號()
Dim M As Variant, D As Object, xRng As Range, i As Integer, 工作頁單號_Rng As Range
With 目的檔.Sheets(工作頁)
'目的檔的工作頁有無準則單號
M = Application.Match(準則單號, .Range(欄位), 0)
'**************************
If IsError(M) Then '無準則單號
M = Split(.UsedRange.Address, "$")
M = M(UBound(M)) '工作頁最底端的列
Do While Application.CountA(.Rows(M)) > 1 '必需沒有資料
M = M + 1
Loop
'*********************************
Set 工作頁單號_Rng = .Range(欄位).Cells(M).Resize(準則單號_Rng.Rows.Count, 準則單號_Rng.Columns.Count)
Msg = Msg & vbLf & 工作頁 & " 加入: " & 準則單號
Else ''有準則單號
Set D = CreateObject("SCRIPTING.DICTIONARY")
.Cells.Sort .Range(欄位).Cells(1), 1, Header:=xlYes '先排序
With .Range(欄位)
M = Application.Match(準則單號, .Cells, 0) '尋找單號列號
'設定工作頁準則單號的範圍*********
Do While .Cells(M) = 準則單號
If TypeName(D(.Cells(M).Value)) <> "Range" Then
Set D(準則單號) = .Range("a" & M).Resize(, 27)
Else
Set D(準則單號) = Union(D(準則單號), .Range("a" & M).Resize(, 27))
End If
M = M + 1
Loop
End With
With D(準則單號)
If .Rows.Count > 準則單號_Rng.Rows.Count Then '工作頁單號列數>準則單號列數
For i = .Rows.Count To 準則單號_Rng.Rows.Count + 1 Step -1
Rows(i).EntireRow.Delete '整列刪除
Next
ElseIf .Rows.Count < 準則單號_Rng.Rows.Count Then '工作頁單號列數<準則單號列數
For i = .Rows.Count + 1 To 準則單號_Rng.Rows.Count
Rows(i + 1).EntireRow.Insert '新增一列
Next
End If
End With
Set 工作頁單號_Rng = D(準則單號).Resize(D(準則單號).Rows.Count)
Msg = Msg & vbLf & 工作頁 & " 更新: " & 準則單號 & " 完畢"
End If
End With
With 工作頁單號_Rng
.Value = 準則單號_Rng.Value
.BorderAround ColorIndex:=3, Weight:=xlThick
End With
End Sub
Sub File_settings(xFile As Workbook, 工作頁 As String) '檔案設定
Dim xPath As String
xPath = ThisWorkbook.Path & "\"
If UCase(工作頁) <> UCase("ERP_Data.XLSX") Then xPath = xPath & "FromERP\"
On Error Resume Next
Set xFile = Workbooks(工作頁)
If Err > 0 Then Set xFile = Workbooks.Open(xPath & 工作頁)
If xFile.Name = "" Then
MsgBox "請查看 " & vbLf & xPath & vbLf & "是否有 [" & 工作頁 & "]"
End
End If
End Sub

複製代碼

作者: PJChen 時間: 2017-7-25 23:32

回復 12# GBKEE

[attach]27547[/attach]
大大,
我挑了其中一個檔來說明...
我看著它執行幾次，初時有點看不懂，因為來源檔及目的檔的資料都對不上，而且它執行過程中一直在存檔。後來我直接把來源檔及目的檔的單據號碼貼在一起比對，發現如下：
1) 目的檔的資料被排序過，而且只有單號排序，其他的欄沒有跟著變動，所以資料錯亂(其實我不要資料排序，我只要按原資料貼上而且是貼上值就好)
2) 目的檔的資料跟之前一樣,當來源檔資料比較少時,它無法Delete多餘的資料 (我一直在思考這個問題,如果這個部份的程式很難達成，乾脆所有的檔案在更新資料後，所有貼上的資料都維持反黑的狀態，意思就像下面的圖檔，更新的資料是B:BF15747,讓反黑保留下來,我一看就知道哪個區塊是更新過的，我再手動Delete 15748:15755，你覺得這樣如何？會不會比較好寫？
[attach]27548[/attach]

3) 執行過程中一直在存檔，這個部份我想只要最後存檔就好了，不然檔案大反而花時間一直在等待，而且我想ERP_Data.xlsx 我一直都在使用，改為存檔後不關閉.
4) ...其實我也暈了，不知道怎麼回覆比較好，等改好以上這些我再try看看有什麼問題吧.
5) 還有Y...我之前二個有關聯的發問放在同一個主題中都被你刪除了，我又要重新發問了，我已經先將其中一個較簡單的先PO上去，另一個正好我在作業當中，發現需求有變動，等我想好了確定要怎麼執行再PO上吧，當然我會用另一個主題，不會混在一起讓你發昏了。

作者: PJChen 時間: 2017-7-26 19:42

回復 13# PJChen

大大,

我今天一測試就卡住了，我不知道有什麼地方要修改，所以先PO上來給你看...
雖然刪了很多資料,檔案還是超過1MB,所以我有分割再上傳.

[attach]27549[/attach]
[attach]27550[/attach]

作者: GBKEE 時間: 2017-7-27 07:50

回復 14# PJChen

12#的程式碼,今天已更新,請重試看看,準則複製到目的檔有用紅框框上.

作者: PJChen 時間: 2017-7-27 22:12

回復 15# GBKEE

大大,
我踹了新的程式好幾次,腦子有點錯亂了，我不知道所執行的結果是否真如我所說，我把來源檔的單號都貼在每個目的檔的最後一欄以方便來回比對，我把我所要的及看到的結果描述一下...
需求：
1. 這6個sheet真的沒有排序的需求,請不要讓它排序,不然資料會亂掉.
2. 更新之後,也不要在目的檔加紅色框線,因為它在功能上沒有的實質的需求,不過因為你這次加了框線,我發現準則不要變動，執行了2次以後就有2個框線,這是否說明它的執行結果有誤？

看到的結果：
3. 它好像更新資料到第N列就不能更新,後面有些新的資料完全沒有貼上.
4. 多餘的資料無法刪除,我不確定新的程式是否沒有這個功能？
5. 我在出貨.sheet實驗,刪除了很多資料,想看它的更新情形，發現沒有更新功能！

結論：
6. 所以其實我不知道它到底能否更新資料.

[attach]27554[/attach][attach]27555[/attach]

作者: GBKEE 時間: 2017-7-28 10:41

回復 16# PJChen

1.沒有排序的需求
來源檔,目的檔中的單號,都不一定只有一列對嗎?
那來源檔,目的檔中的單號都會連續排在一起嗎?
這有關程式碼的編寫
2不要在目的檔加紅色框線,因為它在功能上沒有的實質的需求
加紅框是壤你看到更新的資料在那裡,

With 工作頁單號_Rng
.Value = 準則單號_Rng.Value
'這可以刪掉它
'.BorderAround ColorIndex:=3, Weight:=xlThick
End With

複製代碼

3. 它好像更新資料到第N列就不能更新,後面有些新的資料完全沒有貼上
. 你的範例訂單明細表-> MSO17020036 在B2 ,B2以後的資料是新的資料嗎?
全都貼到 ERP_Datq的訂單嗎!

4. 多餘的資料無法刪除,我不確定新的程式是否沒有這個功能？
還沒,請問如何判斷多餘的資料

作者: PJChen 時間: 2017-7-29 19:51

本帖最後由 PJChen 於 2017-7-29 19:56 編輯

回復 17# GBKEE

大大,

前面許多次的實驗，感覺是因為程式需求不夠明確，所以執行時一直都有錯誤，這次我把目的檔的貼上欄位改為一樣,我想這樣比較有一致性，而且我可能要用到這個欄位，可以避免日後的修改，可否把前面的種種抹掉，重新來過？

準則：
1.. 準則來自VBA報表指令.xlsm VBA指令.sheet G2:H7
2..
[attach]27576[/attach]

來源檔被複製規則：
3.. 準則指定的單號是來源檔要被複製內容的起始點(當同一單號有多筆時,以第一筆為起始準則),一直到最後一列為結束
4.. 準則指定的單號若在來源檔找不到….就是沒有內容要被複製(直接跳過)

目的檔更新規則：
5.. 準則指定的單號也是目的檔要更新內容的起始點(當同一單號有多筆時,以第一筆為起始準則),一直到最後一列為結束
當更新資料貼上後,最後一列若還有資料,則clear一整列(目的檔sheet所指定更新內容的區間,Column前後皆有資料,所以要clear一整列)
[attach]27571[/attach]

6.. 準則指定的單號若在目的檔找不到….表示更新的資料是全新的,就從目的檔的最後一列貼上更新資料
[attach]27572[/attach]

VBA程式需求：
7.. 來源檔及目的檔的內容多寡並沒有一定，所以不能用指定儲存格的方式做複製.貼上
8.. 目的檔原本的格式不要被覆蓋,所以更新時只要貼上值
9.. 所有sheet的單號同一個月的內容並無順序,只有日期才有順序,所以來源檔及目的檔的內容都不要被排序
10.. 來源檔及目的檔在程式執行時要可以自動判斷檔案是否有開啟,未開啟則使用時自動打開
11.. 更新資料後,來源檔不要存檔直接關閉
12.. 更新資料後,目的檔被更新的內容保留反黑的區塊 (這個只是為了方便檢視被更新的內容,而又不會有框線存在,如果這個部份的程式太難寫,可以忽略)
[attach]27573[/attach]

13.. 更新資料後,目的檔最後才存檔而且不要關閉
[attach]27574[/attach]
[attach]27575[/attach]

作者: GBKEE 時間: 2017-7-30 07:51

本帖最後由 GBKEE 於 2017-7-30 07:53 編輯

回復 18# PJChen
有夠清楚的,提問就是要這樣
試試看

Option Explicit
Dim 目的檔 As Workbook, 來源檔 As Workbook
Sub Copy_All()
Dim RngAr(), Rng As Range, M As Variant, xM As Long, E As Integer, Msg As String
With ThisWorkbook.Sheets("VBA指令")
RngAr = .Range("G2", .Range("G2").End(xlDown)).Resize(, 3).Value '準則範圍置於陣列變數中
End With
File_settings 目的檔, "ERP_Data.XLSX"
'**** 比對準則的迴圈 **************
For E = 1 To UBound(RngAr)
File_settings 來源檔, RngAr(E, 1) & ""
M = Application.Match(RngAr(E, 2), 來源檔.Sheets(1).Range("b:b"), 0)
If IsNumeric(M) Then
With 來源檔.Sheets(1)
xM = .Range("b" & M).End(xlDown).Row
Set Rng = .Range("b" & M, .Range("b" & xM)).Resize(, Range(RngAr(E, 3)).Columns.Count)
Rng.copy
End With
With 目的檔.Sheets(Mid(RngAr(E, 1), 1, 2))
M = Application.Match(RngAr(E, 2), .Range("c:c"), 0)
If IsNumeric(M) Then
'***貼上後範圍,會自動的反白,不須有程式碼做反白***
.Range("c" & M).PasteSpecial xlPasteValues
xM = .Range("c" & M).End(xlDown).Row '貼上後這工作表的最後一列號
M = M + Rng.Rows.Count - 1 '準則列號+複製範圍的列數 - 1
If xM > M Then .Range("a" & M + 1, .Range("a" & xM)).EntireRow.Delete
Else
'***貼上後範圍,會自動的反白,不須有程式碼做反白***
.Range("c1").End(xlDown).Offset(1).PasteSpecial xlPasteValues
End If
End With
Application.CutCopyMode = False
Msg = Msg & vbLf & Mid(RngAr(E, 1), 1, 2) & vbTab & RngAr(E, 2) & vbTab & "更新完成!"
Else
Msg = Msg & vbLf & Mid(RngAr(E, 1), 1, 2) & vbTab & RngAr(E, 2) & vbTab & "不用更新!"
End If
來源檔.Close False
Next
目的檔.Save '**目的檔存檔
MsgBox IIf(Msg = "", "沒有任何指定訂單更新", Mid(Msg, 2))
End Sub
'**********來源檔是同VBA報表指令的資料夾\FromERP\*********
Sub File_settings(xFile As Workbook, 工作頁 As String) '檔案設定
Dim xPath As String
xPath = ThisWorkbook.Path & "\"
If UCase(工作頁) <> UCase("ERP_Data.XLSX") Then xPath = xPath & "FromERP\"
On Error Resume Next
Set xFile = Workbooks(工作頁)
If Err > 0 Then Set xFile = Workbooks.Open(xPath & 工作頁)
If xFile.Name = "" Then
MsgBox "請查看 " & vbLf & xPath & vbLf & "是否有 [" & 工作頁 & "]"
End
End If
End Sub

複製代碼

作者: PJChen 時間: 2017-7-30 13:01

回復 19# GBKEE

GBKEE大神...執行完全沒問題.

作者: PJChen 時間: 2018-5-20 23:08

回復 19# GBKEE

您好,
我需要一個數值化的功能，感覺之前您寫的這個程式規則邏輯比較接近，不知可否幫忙修改？感恩！ [attach]28743[/attach]

G欄為工作表名稱
VBA指令存在VBA報表指令II.xlsm
把G欄的工作表全部各別複製一份(檔案是:ERP_Data.xlsx)
另存在D:\5_VBA輸出報表\
存檔名稱命名規則為G欄工作表名稱_年年月月.時時分分
註：ERP_Data.xlsx因為資料很多，為了縮小檔案，已經過刪減及值化

複製代碼

歡迎光臨麻辣家族討論版版 (http://forum.twbts.com/)