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

標題: [發問] VBA 複製data問題(跨Sheet) [打印本頁]

作者: dea172 時間: 2018-4-17 10:45 標題: 使用vba 複製問題

是否可實現，從IPQC數值，
若有五/六筆資料透過按鈕複製到FQC（如圖一），批號-FQC +資料數值
批號-FQC3
批號-FQC2
若有四筆資料透過按鈕複製到FQC（如圖一），批號-FQC +資料數值
批號-FQC3
批號-FQC1
若有三筆資料透過按鈕複製到FQC，批號-FQC +資料數值
批號-FQC3
若有二筆資料透過按鈕複製到FQC，批號-FQC +資料數值
批號-FQC2
若有一筆資料透過按鈕複製到FQC，批號-FQC +資料數值
批號-FQC1
麻煩各位大師幫忙！

[attach]28531[/attach]
[attach]28532[/attach]

作者: dea172 時間: 2018-4-17 13:48 標題: VBA 複製data問題(跨Sheet)

VBA 複製data問題

1.批號抓取來源
說明: 從IPQC內的 G2 欄位將批號複製到A6/A7, 固定將 A6(批號-FQC3)/A7(批號-FQC2)
[attach]28536[/attach]
------------------------------------------------------------------------------------
2.日期抓取data 來源
說明: 直接抓取IPQC C1欄位
[attach]28535[/attach]
------------------------------------------------------------------------------------
3.機台邊號抓取來源
說明: 抓取IPQC L4欄位
[attach]28538[/attach]
------------------------------------------------------------------------------------
4.A1 ~ P data 抓取來源
說明:
若數值有三筆時
IPQC內前三筆數據複製到FQC3 數值內（如圖一）
批號-FQC3  前三筆數值
IPQC內後兩筆數據複製到FQC2 數值內（如圖一）
批號-FQC2  後兩筆數值
圖一
[attach]28537[/attach]
若數值有四筆時
IPQC內前三筆數據複製到FQC3 數值內（如圖二）
批號-FQC3  前三筆數值
IPQC內後兩筆數據複製到FQC2 數值內（如圖二）
批號-FQC2  後兩筆數值
圖二
[attach]28540[/attach]
------------------------------------------------------------------------------------
5.M1 data 抓取來源
說明:
直接將IPQC 內F15/G15 數值複製到 FQC內的AL6/AM6內
[attach]28539[/attach]

FQC 資料需累積下去, 不可清除

作者: 准提部林 時間: 2018-4-17 22:05

Sub TEST()
Dim Arr, Brr(1 To 2, 1 To 39), i&, j%, xE As Range
Arr = [A4:J15]
Brr(1, 1) = Split([G2], "-")(0) & "-FQC3"
Brr(2, 1) = Split([G2], "-")(0) & "-FQC2"
Brr(1, 2) = Year([C1]): Brr(2, 2) = Year([C1])
Brr(1, 3) = [C1]: Brr(2, 3) = [C1]
Brr(1, 4) = [L4]: Brr(2, 4) = [L4]
For i = 0 To UBound(Arr) - 1
If Arr(i + 1, 1) <> "M1" Then
For j = 5 To 7: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j
For j = 5 To 6: Brr(2, i * 3 + j) = Arr(i + 1, j + 4): Next j
Else
For j = 5 To 6: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j
End If
Next i
Set xE = Workbooks("FQC").Sheets("input").[A65536].End(xlUp)(2)
If xE.Row < 6 Then Set xE = xE(2)
xE.Resize(2, 39) = Brr
End Sub

複製代碼

作者: dea172 時間: 2018-4-18 08:19

回復 3# 准提部林

你好,
執行程式後發現有錯誤, 我有嘗試修改程式, 但是仍然無法使用, 可否協助幫忙看一下, 謝謝
-----------------------------------------------------------------------------
原始程式
Set xE = Workbooks("FQC").Sheets("Input").[A65536].End(xlUp)(2)
我有嘗試修改程式為
Set xE = Workbooks("FQC").Sheets("Sheet1").[A65536].End(xlUp)(2)
-----------------------------------------------------------------------------
[attach]28550[/attach]
[attach]28551[/attach]

作者: iamaraymond 時間: 2018-4-18 09:29

回復 4# dea172

這應該是因為你沒有同時把這兩個檔案打開，如果你想只打開IPQC就執行程式的話

Sub TEST()
Dim Arr, Brr(1 To 2, 1 To 39), i&, j%, xE As Range
Arr = [A4:J15]
Brr(1, 1) = Split([G2], "-")(0) & "-FQC3"
Brr(2, 1) = Split([G2], "-")(0) & "-FQC2"
Brr(1, 2) = Year([C1]): Brr(2, 2) = Year([C1])
Brr(1, 3) = [C1]: Brr(2, 3) = [C1]
Brr(1, 4) = [L4]: Brr(2, 4) = [L4]
For i = 0 To UBound(Arr) - 1
If Arr(i + 1, 1) <> "M1" Then
For j = 5 To 7: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j
For j = 5 To 6: Brr(2, i * 3 + j) = Arr(i + 1, j + 4): Next j
Else
For j = 5 To 6: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j
End If
Next i
Workbooks.Open Filename:="C:\Users\User\Downloads\VBA-Test\FQC.xls"
Set xE = Workbooks("FQC").Sheets("input").[A65536].End(xlUp)(2)
If xE.Row < 6 Then Set xE = xE(2)
xE.Resize(2, 39) = Brr
Workbooks("FQC").Close 1
End Sub

複製代碼

把Workbooks.Open Filename改成你的路徑就好

作者: 准提部林 時間: 2018-4-18 10:14

回復 4# dea172

Dim xB As Workbook
On Error Resume Next '以下三行可以檢查FQC是否開啟中
Set xB = Workbooks("FQC")
On Error GoTo 0

If xB Is Nothing Then Set xB = Workbooks.Open(ThisWorkbook.Path & "\FQC.xls") '若未開啟,執行開啟檔案(避免重覆開啟而當機)
Set xE = xB.Sheets("input").[A65536].End(xlUp)(2)
If xE.Row < 6 Then Set xE = xE(2)
xE.Resize(2, 39) = Brr
xB.Close 1 '關閉FQC, 並存檔

作者: dea172 時間: 2018-4-18 14:31

本帖最後由 dea172 於 2018-4-18 14:34 編輯

回復 6# 准提部林

Dear 版主,
感謝快速回復, 但我測試後, 仍有以下幾點問題, 想再次麻煩你, 謝謝!
1.我有更改介面後, 按下Upload 出現Error message, 是否需要修改什麼地方?
[attach]28552[/attach]
2.若FQC 檔案後面兩個資料只要固定抓取前兩筆資料, 如何修改程式?
[attach]28553[/attach]
3.若FQC 檔案資料只要固定抓取5筆資料, 如何修改程式?
[attach]28554[/attach]
4.是否有機會可以新增若從IPQC傳資料至FQC內, 批號重複會無法上傳

作者: 准提部林 時間: 2018-4-18 15:47

回復 7# dea172

Private Sub CommandButton2_Click()
Dim Arr, Brr, i&, j%, xE As Range
Arr = [A3:J17]
ReDim Brr(1 To 2, 1 To [A:AV].Columns.Count)
Brr(1, 1) = Split([G1], "-")(0) & "-FQC3"
Brr(2, 1) = Split([G1], "-")(0) & "-FQC2"
Brr(1, 2) = Year([C1]): Brr(2, 2) = Year([C1])
Brr(1, 3) = [C1]: Brr(2, 3) = [C1]
Brr(1, 4) = [E1]: Brr(2, 4) = [L2]
For i = 0 To UBound(Arr) - 1
If i >= UBound(Arr) - 2 Then '最後兩筆(L/M)
For j = 5 To 6: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j '只抓前2格
Else
For j = 5 To 7: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j '抓前3格
For j = 5 To 6: Brr(2, i * 3 + j) = Arr(i + 1, j + 4): Next j '抓後2格
End If
Next i
Dim xN$, xB As Workbook, xS As Worksheet, xF As Range
xN = "L-15-3-2018-FQC.xls"
On Error Resume Next '以下三行可以檢查FQC是否開啟中
Set xB = Workbooks(xN)
If xB Is Nothing Then Set xB = Workbooks.Open(ThisWorkbook.Path & "\" & xN) '若未開啟,執行開啟檔案
On Error GoTo 0
If xB Is Nothing Then MsgBox "找不到〔" & xN & "〕檔案": Exit Sub
Set xS = xB.Sheets("輸入表")
Set xF = xS.[A:A].Find(Split(Brr(1, 1), "-")(0), Lookat:=xlPart)
If Not xF Is Nothing Then MsgBox "批號重覆": xB.Close 0: Exit Sub
Set xE = xS.[A65536].End(xlUp)(2)
If xE.Row < 6 Then Set xE = xE(2)
xE.Resize(2, UBound(Brr, 2)) = Brr
xB.Close 1 '關閉FQC, 並存檔
End Sub

複製代碼

[attach]28556[/attach]

作者: dea172 時間: 2018-4-19 09:17

本帖最後由 dea172 於 2018-4-19 09:19 編輯

回復 8# 准提部林

你好,
謝謝版主抽空幫忙, 我有使用以上程式, 仍然無法正常執行, 我還是新手, 仍有以下問題, 麻煩了

我總共有三個檔案, 分別為以下 :
1.IPQC 檔案 H欄位有五個數值, FQC 抓取五個數值 (參閲檔案 CUP -1070)
[attach]28559[/attach]

2.IPQC 檔案 H欄位有五個數值, FQC 只抓取前兩個數值(參閲檔案L-15-3)
[attach]28560[/attach]

2.IPQC 檔案 P/M欄位有五個數值, FQC 各抓取前兩個數值(參閲檔案L-26P)
[attach]28561[/attach]

作者: 准提部林 時間: 2018-4-19 10:09

回復 9# dea172

問題描述不清，本來只有一對一檔案，現變成三個，難以下手！！！
１．每個IPQC是否各對應一個FQC？　且檔案名稱前綴相同？
　　例如：L-26P-2018-IPQC　對應　L-26P-2018-FQC，相同為"L-26P-2018"
２．IPQC的Ａ欄項目數量是〔固定〕的？　且必與FQC相對應？
３．抓５格或抓２格的規則是什麼？
　　或者，可利用IPQC的Ｋ欄，抓５筆的輸入５，抓２筆的輸入２，就用這來判斷抓幾格

作者: dea172 時間: 2018-4-19 10:25

回復 10# 准提部林

版主你好,
１．每個IPQC是否各對應一個FQC？　且檔案名稱前綴相同？
　　例如：L-26P-2018-IPQC　對應　L-26P-2018-FQC，相同為"L-26P-2018"
-> 其實檔案是一對一的, 不會共用, 所以程式可以分別設定不會影響

２．IPQC的Ａ欄項目數量是〔固定〕的？　且必與FQC相對應？
-> IPQC A 欄位式固定的, 且與FQC 相對應

３．抓５格或抓２格的規則是什麼？
　　或者，可利用IPQC的Ｋ欄，抓５筆的輸入５，抓２筆的輸入２，就用這來判斷抓幾格
-> 其實我的想法是, 針對不同需求設定不同檔案, 直接將檔案綁死, 怕使用者會有key in 錯誤風險

作者: 准提部林 時間: 2018-4-19 10:35

回復 9# dea172

2.IPQC 檔案 H欄位有五個數值, FQC 只抓取前兩個數值(參閲檔案L-15-3)
圖片看是M欄位???
是否用"M"來判斷取2格??? 還是[最後一筆]取2格???

2.IPQC 檔案 P/M欄位有五個數值, FQC 各抓取前兩個數值(參閲檔案L-26P)
是否用"P"或"M"判斷取2格??? 或是[最後2筆]取2格???

然後, FQC檔案名稱不是固定的, 無法寫死在程式裡(不然每次都要手改)???

作者: dea172 時間: 2018-4-19 10:50

回復 12# 准提部林

版主你好,
不好意思, 要再次麻煩
2.IPQC 檔案 H欄位有五個數值, FQC 只抓取前兩個數值(參閲檔案L-15-3)
圖片看是M欄位???
是否用"M"來判斷取2格???  還是[最後一筆]取2格???
-> 這个會隨著資料而不同, 這是否可以依需求而自行變更?
EX: 要"M"欄位, 就從程式中更改為"M"欄位
   要"H"欄位, 就從程式中更改為"H"欄位

2.IPQC 檔案 P/M欄位有五個數值, FQC 各抓取前兩個數值(參閲檔案L-26P)
是否用"P"或"M"判斷取2格???  或是[最後2筆]取2格???
->  對, 這比較特別, 這个檔案為[最後2筆]取2格
然後, FQC檔案名稱不是固定的, 無法寫死在程式裡(不然每次都要手改)???
->  FQC檔案名稱這个我可以依照我的檔案需求手動更改變更

作者: Hsieh 時間: 2018-4-19 15:37

回復 13# dea172

Sub FQC_IPQC()
Dim Ay(0 To 1), A As Range, C As Range, y&, d#, m&, i!, Lot1$, Lot2, f, fd$, fs$, fc$
Do
fd = Application.GetOpenFilename("Excel Files (*.xls),*.xls", , "請選擇IPQC檔", , False)
f = Split(fd, "\")
fs = f(UBound(f))
If InStr(fs, "IPQC") = 0 Then MsgBox "檔案選取不是IPQC檔" & Chr(10) & "請重新選擇"
Loop While InStr(fs, "IPQC") = 0
fc = Replace(fd, "IPQC.xls", "FQC.xls")
With Workbooks.Open(fc)
With Workbooks.Open(fd)
With .Sheets("Transfer")
Lot1 = Split(.[G2], "-")(0) & "-FQC3"
Lot2 = Split(.[G2], "-")(0) & "-FQC2"
y = Year(.[C1])
d = CDate(Format(.[C1], "m/d"))
m = .[L4]
Ay(0) = Array(Lot1, y, d, m)
Ay(1) = Array(Lot2, y, d, m)
Dim ar(0 To 1, 0 To 34)
For Each A In .[F4:F15]
For i = 0 To 2
ar(0, s) = A.Offset(, i).Value
ar(1, s) = A.Offset(, i + 3).Value
s = s + 1
If s = 35 Then GoTo 10
Next
Next
10
End With
.Close 0
End With
With .Sheets("Input")
Set C = .Cells(.Rows.Count, 1).End(xlUp).Offset(1)
C.Resize(2, 4) = Application.Transpose(Application.Transpose(Ay))
C.Offset(, 4).Resize(2, 35) = ar
End With
End With
End Sub

複製代碼

作者: dea172 時間: 2018-4-19 15:51

回復 14# Hsieh

版主你好,
感謝幫忙, 我有試過,
1.沒有重複批號確認,
2.每傳一次資料, 使用者還需要開啟IPQC 檔案, 是否有更方便方式, 謝謝!
註: IPQC & FQC 檔案都是放同一資料夾下

作者: 准提部林 時間: 2018-4-19 16:05

本帖最後由准提部林於 2018-4-19 16:10 編輯

回復 15# dea172

[attach]28567[/attach]

這個FQC檔名自動與IPQC匹配:
[attach]28568[/attach]

作者: dea172 時間: 2018-4-19 16:23

回復 16# 准提部林

版主你好,
測試後OK, 不好意思, 但我還有一個問題想請教, 再次麻煩了, 謝謝
若想跳過 IPQC檔案的 P 欄位, 複製時不將P欄位複製到FQC內, 是否有程式可使用?
[attach]28569[/attach]

作者: 准提部林 時間: 2018-4-19 16:37

回復 17# dea172

For i = 0 To UBound(Arr) - 1
If Arr(i + 1, 1) = "P" Then
   '這裡空白即可(不做任何動作)
ElseIf Arr(i + 1, 1) = "M" Then
   For j = 5 To 6: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j '只抓前2格
   Else
   For j = 5 To 7: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j '抓前3格
         For j = 5 To 6: Brr(2, i * 3 + j) = Arr(i + 1, j + 4): Next j '抓後2格
End If
Next i

作者: 准提部林 時間: 2018-4-19 16:43

本帖最後由准提部林於 2018-4-19 16:45 編輯

回復 17# dea172

若是要排除多個:
If InStr("-A2-H-P-", "-" & Trim(Arr(i + 1, 1)) & "-") Then

A2,H,P 都不錄入

因為檔案中A2後多了一個空格, 須用Trim清除

記住：這個排除要放在IF條件的第一個，其它再用ELSEIF接其它條件

作者: 准提部林 時間: 2018-4-19 16:46

為了防呆，在程式碼的前端再加這三行：
If IsDate([C1]) = False Then MsgBox "日期格式錯誤或未輸入!!": Exit Sub
If [E1] = "" Then MsgBox "Machine No 未輸入!!": Exit Sub
If [G1] Like "########-####" = False Then MsgBox "Lot No 錯誤或未輸入!!": Exit Sub

作者: dea172 時間: 2018-4-19 16:59

回復 18# 准提部林

版主你好,
測試後, 可以跳過指定欄位, FQC M 欄位跑到後面了, 附上圖片與程式碼

[attach]28571[/attach]
[attach]28572[/attach]

作者: 准提部林 時間: 2018-4-19 17:24

回復 21# dea172

不是欄位都是固定的???
實在沒時間再去修改程式,
等其他版主來幫忙吧!

作者: 准提部林 時間: 2018-4-19 20:42

最後一個版本，以Ｋ欄去控制取５格或２格或排除不取：
[attach]28573[/attach]

作者: Hsieh 時間: 2018-4-20 13:49

回復 15# dea172

1.沒有重複批號確認,
2.每傳一次資料, 使用者還需要開啟IPQC 檔案, 是否有更方便方式, 謝謝!
註: IPQC & FQC 檔案都是放同一資料夾下

1.不是每個 IPQC 對應一個 FQC 何來重複批號?當然也不會有資料累加的問題
2.我14#程式是比對兩個相同前綴檔名的IPQC & FQC
若是你已經開啟其中某一檔案才做比對，那就請清楚敘述你的作業流程
才知道要如何去簡化

作者: dea172 時間: 2018-4-26 13:05

回復 23# 准提部林

版主你好,
再次請問一個問題, 若想將IPQC & FQC 資料放置不同路徑下, 是否可實現此功能? 謝謝

作者: 准提部林 時間: 2018-4-26 13:18

回復 25# dea172

If xB Is Nothing Then Set xB = Workbooks.Open("自行輸入路徑" & "\" & xN)

作者: dea172 時間: 2018-4-26 13:27

回復 26# 准提部林

版主你好,
謝謝版主, 測試可以, 原來這麼簡單.

作者: dea172 時間: 2018-9-11 13:40

回復 dea172

For i = 0 To UBound(Arr) - 1
If Arr(i + 1, 1) = "" Then
'這裡空白即可 ...
准提部林發表於 2018-4-19 16:37

版主你好,
若我想刪除A6欄位(A4), A7~A17 全部往上一格, 想了好久, 但始終無法修改好程式碼, 是否可以幫忙修改, 謝謝!
[attach]29376[/attach]

作者: 准提部林 時間: 2018-9-11 14:45

回復 28# dea172

刪掉A4, 轉存檔資料的欄位順序就對不上了,
不懂~~

作者: dea172 時間: 2018-9-11 14:59

回復 29# 准提部林

版主你好,
就是我想將A4欄位整個資料刪除, 後面欄位往上移動一格(如下圖)
轉存檔資料的欄位順序就對不上了, 是沒錯, 所以要修改code, 只是不知道如何修改code
[attach]29377[/attach]

作者: 准提部林 時間: 2018-9-11 19:43

回復 30# dea172

只說要刪A4, 什麼條件刪? 何時刪? 轉檔前刪? 或轉檔後?
其它的刪不刪??
刪完後, 轉存檔中的A4欄位置如何處理?
轉檔前, 轉存檔是否已有A4欄資料?

沒有詳細說明, 什也做不了, 何況這程式也有些時日, 得重新了解//

作者: dea172 時間: 2018-9-12 13:17

回復 31# 准提部林

版主你好,
不好意思, 我研究出來, 還是謝謝你抽空幫忙看

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