PJChen

　暱稱: PJ

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2021-10-30 23:05 | 只看該作者

[發問] 依料號填入資料

大大好,

新月工作表E:J欄,以料號為依據,要抓取"比"工作表的資料
二個工作表資料都會有增加or減少,資料常要更新
"比"工作表是資料來源,當其資料為空白時,"新月"工作表同料號的欄位=空白

如何寫二個程式,達成如"新月"工作表 E:J欄已填入資料的結果?

依料號填入資料.rar (30.57 KB)

程式I
"新月"工作表E:G
A欄料號= "比"工作表E欄料號時,則代入以下資料
"新月" E欄 = "比" I欄
"新月" F欄 = "比" J欄
"新月" G欄 = "比" P

程式II
"新月"工作表I:J
依A欄料號= "比"工作表E欄料號,則
1)
"比"工作表AK欄=1or3 ...則  "新月" I欄="V"
"比"工作表AK欄=2 ...則  "新月" I欄="O"
2)
"比"工作表AN欄>0 ...則  "新月" J欄="V"

樓主熱帖

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

8^#

發表於 2021-11-14 22:15 | 只看該作者

回復 7# PJChen

Brr = Range([新月!K1], [新月!a63356].End(3))
For i = 4 To UBound(Brr)
R = xD(Brr(i, 1) & ""): If R = 0 Then R = UBound(Arr)
   For j = 1 To 7
      If j <> 4 Then Brr(i - 3, j) = Arr(R, Array(5, 14, 12, "", 33, 36, 11)(j - 1))
   Next
   Brr(i - 3, 4) = ""
Next i
[新月!e4].Resize(UBound(Brr) - 3, 7) = Brr

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

7^#

發表於 2021-11-14 13:55 | 只看該作者

回復 6# 准提部林

准大好,
我想在新月!K欄填入資料
K欄=比!O欄
請問程式要怎麼修改?

依料號填入資料.rar (23.29 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

6^#

發表於 2021-11-8 20:24 | 只看該作者

回復 5# PJChen

它是抓"T欄"--"地點統計", 若不要, 改下
For j = 1 To 6
IF j <> 4 then Brr(i - 3, j) = Arr(R, Array(5, 6, 12, "", 33, 36)(j - 1))
Next j

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

5^#

發表於 2021-11-8 17:10 | 只看該作者

回復 4# 准提部林
准大好,
新月工作表H欄"歸位"原本是空白,
但執行後會填入一些數字,不過我找不到數字的由來,
請幫忙看下?

依料號填入資料.rar (25.62 KB)

TOP

准提部林

版主 Rank: 7 Rank: 7 Rank: 7

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

4^#

發表於 2021-11-7 11:11 | 只看該作者

Sub TEST_A1()
Dim Arr, Brr, xD, i&, j%, R&, V
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([比!an1], [比!e63356].End(3)(2))  '範圍--向下多取一行空白列, 若比對不到就利用這行填入空白
For i = 4 To UBound(Arr) - 1
xD(Arr(i, 1) & "") = i:  V = Arr(i, 33)
If V > 0 Then Arr(i, 33) = IIf(V Mod 2, "V", "O")
Arr(i, 36) = IIf(Arr(i, 36) > 0, "V", "")
Next
Brr = Range([新月!j1], [新月!a63356].End(3))
For i = 4 To UBound(Brr)
R = xD(Brr(i, 1) & ""): If R = 0 Then R = UBound(Arr)
For j = 1 To 6
      Brr(i - 3, j) = Arr(R, Array(5, 6, 12, 16, 33, 36)(j - 1))
Next j
101: Next i
[新月!e4].Resize(UBound(Brr) - 3, 6) = Brr
End Sub

TOP

PJChen

　暱稱: PJ

大學生 Rank: 4

帖子: 913
主題: 150
精華: 0
積分: 1089
點名: 0
作業系統: win10
軟體版本: office 2019
閱讀權限: 50
性別: 女
註冊時間: 2011-8-28
最後登錄: 2023-7-19

論壇榮譽勳章論壇贊助勳章

3^#

發表於 2021-11-2 20:14 | 只看該作者

回復 2# samwang

謝謝Sam
測試OK

TOP

samwang

大學生 Rank: 4

帖子: 976
主題: 7
精華: 0
積分: 1018
點名: 0
作業系統: Win10
軟體版本: Office 2016
閱讀權限: 50
性別: 男
註冊時間: 2013-4-19
最後登錄: 2024-10-30

2^#

發表於 2021-11-1 10:35 | 只看該作者

回復 1# PJChen

請測試看看，謝謝
Sub test()
Dim Arr, xD, T$, i&
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([比!an1], [比!e63356].End(3))
For i = 4 To UBound(Arr)
T = Arr(i, 1)
xD(T) = Array(Arr(i, 5), Arr(i, 6), Arr(i, 12), Arr(i, 16), Arr(i, 33), Arr(i, 36))
Next
With Sheets("新月")
Arr = .Range(.[j1], .[a63356].End(3))
For i = 4 To UBound(Arr)
T = Arr(i, 1)
If xD.Exists(T) Then
      Arr(i, 5) = xD(T)(0): Arr(i, 6) = xD(T)(1): Arr(i, 7) = xD(T)(2)
      If xD(T)(4) <> "" Then Arr(i, 9) = IIf(xD(T)(4) Mod 2, "V", "O")
      Arr(i, 10) = IIf(xD(T)(5) > 0, "V", "")
End If
Next
.[a1].Resize(UBound(Arr), 10) = Arr
End With
End Sub

TOP