返回列表 上一主題 發帖

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

使用vba 複製問題

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


未命名-1.jpg
2018-4-17 10:43

未命名-2.jpg
2018-4-17 10:44

VBA-Test.zip (425.36 KB)

TOP

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

VBA 複製data問題

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

------------------------------------------------------------------------------------
2.日期抓取data 來源
說明: 直接抓取IPQC C1欄位
Date.jpg
2018-4-17 13:32

------------------------------------------------------------------------------------
3.機台邊號抓取來源
說明: 抓取IPQC L4欄位
Machine No.jpg
2018-4-17 13:35

------------------------------------------------------------------------------------
4.A1 ~ P data 抓取來源
說明:
若數值有三筆時
IPQC內前三筆數據複製到FQC3 數值內 (如圖一)
批號-FQC3  前三筆數值
IPQC內後兩筆數據複製到FQC2 數值內 (如圖一)
批號-FQC2  後兩筆數值
圖一
A1-Data.jpg
2018-4-17 13:34

若數值有四筆時
IPQC內前三筆數據複製到FQC3 數值內 (如圖二)
批號-FQC3  前三筆數值
IPQC內後兩筆數據複製到FQC2 數值內 (如圖二)
批號-FQC2  後兩筆數值
圖二
A1-Data-4.jpg
2018-4-17 13:41

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


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

VBA-Test.zip (89.84 KB)

  1. Sub TEST()
  2. Dim Arr, Brr(1 To 2, 1 To 39), i&, j%, xE As Range
  3. Arr = [A4:J15]
  4. Brr(1, 1) = Split([G2], "-")(0) & "-FQC3"
  5. Brr(2, 1) = Split([G2], "-")(0) & "-FQC2"
  6. Brr(1, 2) = Year([C1]): Brr(2, 2) = Year([C1])
  7. Brr(1, 3) = [C1]: Brr(2, 3) = [C1]
  8. Brr(1, 4) = [L4]: Brr(2, 4) = [L4]
  9. For i = 0 To UBound(Arr) - 1
  10.     If Arr(i + 1, 1) <> "M1" Then
  11.        For j = 5 To 7: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j
  12.        For j = 5 To 6: Brr(2, i * 3 + j) = Arr(i + 1, j + 4): Next j
  13.     Else
  14.        For j = 5 To 6: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j
  15.     End If
  16. Next i
  17. Set xE = Workbooks("FQC").Sheets("input").[A65536].End(xlUp)(2)
  18. If xE.Row < 6 Then Set xE = xE(2)
  19. xE.Resize(2, 39) = Brr
  20. End Sub
複製代碼
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

回復 3# 准提部林

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

error-1.jpg
2018-4-18 08:17

TOP

回復 4# dea172

這應該是因為你沒有同時把這兩個檔案打開,如果你想只打開IPQC就執行程式的話
  1. Sub TEST()
  2. Dim Arr, Brr(1 To 2, 1 To 39), i&, j%, xE As Range
  3. Arr = [A4:J15]
  4. Brr(1, 1) = Split([G2], "-")(0) & "-FQC3"
  5. Brr(2, 1) = Split([G2], "-")(0) & "-FQC2"
  6. Brr(1, 2) = Year([C1]): Brr(2, 2) = Year([C1])
  7. Brr(1, 3) = [C1]: Brr(2, 3) = [C1]
  8. Brr(1, 4) = [L4]: Brr(2, 4) = [L4]
  9. For i = 0 To UBound(Arr) - 1
  10.     If Arr(i + 1, 1) <> "M1" Then
  11.        For j = 5 To 7: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j
  12.        For j = 5 To 6: Brr(2, i * 3 + j) = Arr(i + 1, j + 4): Next j
  13.     Else
  14.        For j = 5 To 6: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j
  15.     End If
  16. Next i
  17. Workbooks.Open Filename:="C:\Users\User\Downloads\VBA-Test\FQC.xls"
  18. Set xE = Workbooks("FQC").Sheets("input").[A65536].End(xlUp)(2)
  19. If xE.Row < 6 Then Set xE = xE(2)
  20. xE.Resize(2, 39) = Brr

  21. Workbooks("FQC").Close 1
  22. End Sub
複製代碼
把Workbooks.Open Filename改成你的路徑就好
Excel VBA網頁資料收集教學:
http://forum.twbts.com/thread-20848-1-1.html

TOP

回復 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, 並存檔
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

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

回復 6# 准提部林

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

2.若FQC 檔案後面兩個資料只要固定抓取前兩筆資料, 如何修改程式?
FQC-2.jpg
2018-4-18 14:28

3.若FQC 檔案資料只要固定抓取5筆資料, 如何修改程式?
FQC-5.jpg
2018-4-18 14:29

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

VBA 資料測試.zip (434.92 KB)

TOP

回復 7# dea172
  1. Private Sub CommandButton2_Click()
  2. Dim Arr, Brr, i&, j%, xE As Range
  3. Arr = [A3:J17]
  4. ReDim Brr(1 To 2, 1 To [A:AV].Columns.Count)
  5. Brr(1, 1) = Split([G1], "-")(0) & "-FQC3"
  6. Brr(2, 1) = Split([G1], "-")(0) & "-FQC2"
  7. Brr(1, 2) = Year([C1]): Brr(2, 2) = Year([C1])
  8. Brr(1, 3) = [C1]: Brr(2, 3) = [C1]
  9. Brr(1, 4) = [E1]: Brr(2, 4) = [L2]
  10. For i = 0 To UBound(Arr) - 1
  11.     If i >= UBound(Arr) - 2 Then '最後兩筆(L/M)
  12.        For j = 5 To 6: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j '只抓前2格
  13.     Else
  14.        For j = 5 To 7: Brr(1, i * 3 + j) = Arr(i + 1, j + 1): Next j '抓前3格
  15.        For j = 5 To 6: Brr(2, i * 3 + j) = Arr(i + 1, j + 4): Next j '抓後2格
  16.     End If
  17. Next i

  18. Dim xN$, xB As Workbook, xS As Worksheet, xF As Range
  19. xN = "L-15-3-2018-FQC.xls"
  20. On Error Resume Next '以下三行可以檢查FQC是否開啟中
  21. Set xB = Workbooks(xN)
  22. If xB Is Nothing Then Set xB = Workbooks.Open(ThisWorkbook.Path & "\" & xN) '若未開啟,執行開啟檔案
  23. On Error GoTo 0
  24. If xB Is Nothing Then MsgBox "找不到〔" & xN & "〕檔案": Exit Sub

  25. Set xS = xB.Sheets("輸入表")
  26. Set xF = xS.[A:A].Find(Split(Brr(1, 1), "-")(0), Lookat:=xlPart)
  27. If Not xF Is Nothing Then MsgBox "批號重覆": xB.Close 0: Exit Sub
  28. Set xE = xS.[A65536].End(xlUp)(2)
  29. If xE.Row < 6 Then Set xE = xE(2)
  30. xE.Resize(2, UBound(Brr, 2)) = Brr
  31. xB.Close 1  '關閉FQC, 並存檔
  32. End Sub
複製代碼
L-15-3-2018-IPQC.rar (75.84 KB)
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

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

回復 8# 准提部林

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

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


2.IPQC 檔案 H欄位有五個數值, FQC 只抓取前兩個數值(參閲檔案L-15-3)
2 PCS.jpg
2018-4-19 09:14


2.IPQC 檔案 P/M欄位有五個數值, FQC 各抓取前兩個數值(參閲檔案L-26P)
2-2 PCS.jpg
2018-4-19 09:15

CUP 1070.zip (56.28 KB)

L-15-3.zip (63.61 KB)

L-26P.zip (89.09 KB)

TOP

回復 9# dea172

問題描述不清,本來只有一對一檔案,現變成三個,難以下手!!!
1.每個IPQC是否各對應一個FQC? 且檔案名稱前綴相同?
  例如:L-26P-2018-IPQC 對應 L-26P-2018-FQC,相同為"L-26P-2018"
2.IPQC的A欄項目數量是〔固定〕的? 且必與FQC相對應?
3.抓5格或抓2格的規則是什麼?
  或者,可利用IPQC的K欄,抓5筆的輸入5,抓2筆的輸入2,就用這來判斷抓幾格
EXCEL參考資料:
http://blog.xuite.net/smile1000mile/blog

TOP

        靜思自在 : 一個人的快樂.不是因為他擁有得多,而是因為他計較得少。
返回列表 上一主題