- 帖子
- 5923
- 主題
- 13
- 精華
- 1
- 積分
- 5986
- 點名
- 0
- 作業系統
- win10
- 軟體版本
- Office 2010
- 閱讀權限
- 150
- 性別
- 男
- 來自
- 台灣基隆
- 註冊時間
- 2010-5-1
- 最後登錄
- 2022-1-23
        
|
12#
發表於 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
|
|
發表於 2017-7-16 14:54
| 
