1234
返回列表 上一主題 發帖

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

dea172

帖子
32 
主題
7 
精華
0 
積分
89 
點名
0  
作業系統
windows 
軟體版本
7.0 
閱讀權限
20 
註冊時間
2016-10-20 
最後登錄
2020-11-25 
1# 跳轉到 »
發表於 2018-4-17 10:45 | 只看該作者

使用vba 複製問題

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



VBA-Test.zip (425.36 KB)

TOP

dea172

帖子
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)

收藏 分享

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-22 
3#
發表於 2018-4-17 22:05 | 只看該作者
  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
複製代碼

TOP

dea172

帖子
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)
-----------------------------------------------------------------------------

TOP

iamaraymond
　暱稱: Raymond Chien

中學生Rank: 2

帖子
109 
主題
12 
精華
0 
積分
177 
點名
0  
作業系統
win10 
軟體版本
office2013 
閱讀權限
20 
性別
男 
來自
高雄 
註冊時間
2017-11-19 
最後登錄
2023-7-5 
5#
發表於 2018-4-18 09:29 | 只看該作者
回復 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

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

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-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, 並存檔

TOP

dea172

帖子
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)

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-22 
8#
發表於 2018-4-18 15:47 | 只看該作者
回復 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

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

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

TOP

dea172

帖子
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)

TOP

准提部林

帖子
2834 
主題
10 
精華
0 
積分
2890 
點名
0  
作業系統
〔略〕 
軟體版本
〔略〕 
閱讀權限
100 
性別
男 
來自
〔略〕 
註冊時間
2013-5-13 
最後登錄
2024-11-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的Ｋ欄，抓５筆的輸入５，抓２筆的輸入２，就用這來判斷抓幾格

TOP

        靜思自在 : 能付出愛心就是福，能消除煩惱就是慧。
1234
返回列表 上一主題