[發問] VBA 複製data問題(跨Sheet)

帖子: 32
主題: 7
精華: 0
積分: 89
點名: 0
作業系統: windows
軟體版本: 7.0
閱讀權限: 20
註冊時間: 2016-10-20
最後登錄: 2020-11-25

2^# 倒序看帖

打印

字體大小: tT

發表於 2018-4-17 13:48 | 只看該作者

[發問] VBA 複製data問題(跨Sheet)

VBA 複製data問題

1.批號抓取來源
說明: 從IPQC內的 G2 欄位將批號複製到A6/A7, 固定將 A6(批號-FQC3)/A7(批號-FQC2)

------------------------------------------------------------------------------------
2.日期抓取data 來源
說明: 直接抓取IPQC C1欄位

------------------------------------------------------------------------------------
3.機台邊號抓取來源
說明: 抓取IPQC L4欄位

------------------------------------------------------------------------------------
4.A1 ~ P data 抓取來源
說明:
若數值有三筆時
IPQC內前三筆數據複製到FQC3 數值內（如圖一）
批號-FQC3 前三筆數值
IPQC內後兩筆數據複製到FQC2 數值內（如圖一）
批號-FQC2 後兩筆數值
圖一

若數值有四筆時
IPQC內前三筆數據複製到FQC3 數值內（如圖二）
批號-FQC3 前三筆數值
IPQC內後兩筆數據複製到FQC2 數值內（如圖二）
批號-FQC2 後兩筆數值
圖二

------------------------------------------------------------------------------------
5.M1 data 抓取來源
說明:
直接將IPQC 內F15/G15 數值複製到 FQC內的AL6/AM6內

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

VBA-Test.zip (89.84 KB)

帖子: 2839
主題: 10
精華: 0
積分: 2895
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-12-22

3^#

發表於 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

複製代碼

帖子: 32
主題: 7
精華: 0
積分: 89
點名: 0
作業系統: windows
軟體版本: 7.0
閱讀權限: 20
註冊時間: 2016-10-20
最後登錄: 2020-11-25

4^#

發表於 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)
-----------------------------------------------------------------------------

iamaraymond

　暱稱: Raymond Chien

帖子: 109
主題: 12
精華: 0
積分: 177
點名: 0
作業系統: win10
軟體版本: office2013
閱讀權限: 20
性別: 男
來自: 高雄
註冊時間: 2017-11-19
最後登錄: 2023-7-5

5^#

發表於 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改成你的路徑就好

Excel VBA網頁資料收集教學:
http://forum.twbts.com/thread-20848-1-1.html

帖子: 2839
主題: 10
精華: 0
積分: 2895
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-12-22

6^#

發表於 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, 並存檔

帖子: 32
主題: 7
精華: 0
積分: 89
點名: 0
作業系統: windows
軟體版本: 7.0
閱讀權限: 20
註冊時間: 2016-10-20
最後登錄: 2020-11-25

7^#

發表於 2018-4-18 14:31 | 只看該作者

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

回復 6# 准提部林

Dear 版主,
感謝快速回復, 但我測試後, 仍有以下幾點問題, 想再次麻煩你, 謝謝!
1.我有更改介面後, 按下Upload 出現Error message, 是否需要修改什麼地方?

2.若FQC 檔案後面兩個資料只要固定抓取前兩筆資料, 如何修改程式?

3.若FQC 檔案資料只要固定抓取5筆資料, 如何修改程式?

4.是否有機會可以新增若從IPQC傳資料至FQC內, 批號重複會無法上傳

VBA 資料測試.zip (434.92 KB)

帖子: 2839
主題: 10
精華: 0
積分: 2895
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-12-22

8^#

發表於 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

複製代碼

L-15-3-2018-IPQC.rar (75.84 KB)

帖子: 32
主題: 7
精華: 0
積分: 89
點名: 0
作業系統: windows
軟體版本: 7.0
閱讀權限: 20
註冊時間: 2016-10-20
最後登錄: 2020-11-25

9^#

發表於 2018-4-19 09:17 | 只看該作者

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

回復 8# 准提部林

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

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

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

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

CUP 1070.zip (56.28 KB)

L-15-3.zip (63.61 KB)

L-26P.zip (89.09 KB)

帖子: 2839
主題: 10
精華: 0
積分: 2895
點名: 0
作業系統: 〔略〕
軟體版本: 〔略〕
閱讀權限: 100
性別: 男
來自: 〔略〕
註冊時間: 2013-5-13
最後登錄: 2024-12-22

10^#

發表於 2018-4-19 10:09 | 只看該作者

回復 9# dea172

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