[發問] 依指定區間日期、帳號 填入資料

PJChen

大大們好,

1..        在"說明"工作表中有4個帳號"大、美、佳、振",符合帳號、日期(同帳號及日期,不一定只有一筆)
2..        以"說明"工作表中的交運日期,最大值&最小值為區間,將M欄的取板編號、O欄的預約板數填入"預約"工作表中的G/C欄
3..        取板編號填入時,依原號碼,在最前面加上#0000(例:編號為118120,則為#0000118120)
4..        "預約"工作表中,不屬於交運日期區間值的所有資料及帳號,都不要有任何變動(有資料的,保留原資料,無資料則空白)
5..        例如：1/13~1/29不在此區間,已有的原資料不可變動,1/15 & 1/18也有非屬4大帳號,也不可填入資料

請問要達到這些要求,用函數or程式可以達成?
預約取板.rar (21.1 KB)

下載次數: 11

2021-1-16 15:59

軒云熊

回復 1# PJChen
有空幫我試試看是不是這樣比對 感謝 ^^"

1. Public Sub 跨工作表比對練習()
   
2. 
   
3.     Arr = [說明!I2].CurrentRegion
   
4.     Brr = [預約!A1].CurrentRegion
   
5.    
   
6.     For X = 2 To UBound(Arr)
   
7.         A = Arr(X, 1) & "-" & Arr(X, 4)
   
8.         For Y = 2 To UBound(Brr)
   
9.             B = Brr(Y, 2) & "-" & Brr(Y, 1)
   
10.             If A = B And Arr(X, 4) <> "" Then
    
11.                 Brr(Y, 3) = Arr(X, 7)
    
12.                 Brr(Y, 7) = "#0000" & Arr(X, 5)
    
13.             End If
    
14.         Next Y
    
15.     Next X
    
16.    
    
17.     [預約!A1].Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
18. 
    
19. End Sub

複製代碼

准提部林

Sub 預約更新()
Dim Arr, xD, i&, T$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([說明!R1], [說明!i65536].End(xlUp))
For i = 3 To UBound(Arr)
    If Arr(i, 1) = "" Or IsDate(Arr(i, 4)) Then
       T = Arr(i, 1) & "|" & Arr(i, 4)
       xD(T) = xD(T) + Val(Arr(i, 7)) '同日同號不只一筆,累加
       xD(T & "/m") = "#0000" & Arr(i, 5) '取板編號
    End If
Next i
Arr = Range([預約!G1], [預約!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    T = Arr(i, 2) & "|" & Arr(i, 1)
    If xD.Exists(T) Then
       Arr(i, 3) = xD(T)
       Arr(i, 7) = xD(T & "/m")
    End If
Next i
[預約!A1].Resize(UBound(Arr), 7) = Arr
End Sub


'==========================

PJChen

回復 3# 准提部林
回復 2# 軒云熊

感謝兩位大大,
二個程式測試結果都相同：
同一日期、同帳號有多筆取板資料時,帶出的結果有誤
取板編號只會帶出最後一筆,數量會變成累加

以下圖片為跑程式結果 v.s. 正確資料

下載 (51.62 KB)

2021-1-17 16:04

准提部林

回復 4# PJChen


Sub 預約更新()
Dim Arr, xD, i&, T$
Set xD = CreateObject("Scripting.Dictionary")
Arr = Range([說明!R1], [說明!i65536].End(xlUp))
For i = 3 To UBound(Arr)
    If Arr(i, 1) <> "" And IsDate(Arr(i, 4)) Then
       T = Arr(i, 1) & "|" & Arr(i, 4) & "#0000" & Arr(i, 5)
       xD(T) = xD(T) + Val(Arr(i, 7))
    End If
Next i
Arr = Range([預約!G1], [預約!A65536].End(xlUp))
For i = 2 To UBound(Arr)
    T = Arr(i, 2) & "|" & Arr(i, 1) & Arr(i, 7)
    If xD.Exists(T) Then Arr(i, 3) = xD(T)
Next i
[預約!A1].Resize(UBound(Arr), 7) = Arr
End Sub

PJChen

回復 5# 准提部林
大大,

我試了幾次,都無動作,不知發生什麼事...

PJChen

回復 5# 准提部林

試了幾次還是不行,請大大幫忙看下程式！
感謝
預約取板.rar (21.46 KB)

下載次數: 5

2021-1-17 18:24

軒云熊

回復 7# PJChen

有空再試試看這樣行不行  感謝

1. Public Sub 跨工作表比對練習()
   
2. 
   
3.     Arr = [說明!I2].CurrentRegion
   
4.     Brr = [預約!A1].CurrentRegion
   
5. 
   
6.     For X = 2 To UBound(Arr)
   
7.         A = Arr(X, 1) & "-" & Arr(X, 4)
   
8.         For Y = X To UBound(Brr)
   
9.             B = Brr(Y, 2) & "-" & Brr(Y, 1)
   
10.             If A = B And Brr(Y, 3) = "" Then K = 0
    
11.             If A = B And Arr(X, 4) <> "" And K <> 1 Then
    
12.                 K = 1
    
13.                 Brr(Y, 3) = Arr(X, 7)
    
14.                 Brr(Y, 7) = "#0000" & Arr(X, 5)
    
15.             Exit For
    
16.             End If
    
17.         Next Y
    
18.     Next X
    
19. 
    
20.     [預約!A1].Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr
    
21. 
    
22. End Sub

複製代碼

PJChen

回復 8# 軒云熊

感謝！
這個程式OK了

PJChen

回復 8# 軒云熊
您好,
程式在實作時,發現了問題:執行程式後,會將D:F欄的公式值化,且不屬於這個區間的也都值化了,
請問要如何修改程式,讓D:F欄不受程式影響,保持原樣(有公式則保留)？
預約取板.rar (24.19 KB)

下載次數: 8

2021-1-20 21:52