返回列表 上一主題 發帖

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

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

大大們好,

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)

回復 1# PJChen
有空幫我試試看是不是這樣比對 感謝 ^^"
  1. Public Sub 跨工作表比對練習()

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

  17. End Sub
複製代碼

TOP

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


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

TOP

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

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

以下圖片為跑程式結果 v.s. 正確資料
20210117.160408.jpg
2021-1-17 16:04

TOP

回復 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

TOP

回復 5# 准提部林
大大,

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

TOP

本帖最後由 PJChen 於 2021-1-17 18:24 編輯

回復 5# 准提部林

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

TOP

回復 7# PJChen

有空再試試看這樣行不行  感謝
  1. Public Sub 跨工作表比對練習()

  2.     Arr = [說明!I2].CurrentRegion
  3.     Brr = [預約!A1].CurrentRegion

  4.     For X = 2 To UBound(Arr)
  5.         A = Arr(X, 1) & "-" & Arr(X, 4)
  6.         For Y = X To UBound(Brr)
  7.             B = Brr(Y, 2) & "-" & Brr(Y, 1)
  8.             If A = B And Brr(Y, 3) = "" Then K = 0
  9.             If A = B And Arr(X, 4) <> "" And K <> 1 Then
  10.                 K = 1
  11.                 Brr(Y, 3) = Arr(X, 7)
  12.                 Brr(Y, 7) = "#0000" & Arr(X, 5)
  13.             Exit For
  14.             End If
  15.         Next Y
  16.     Next X

  17.     [預約!A1].Resize(UBound(Brr, 1), UBound(Brr, 2)) = Brr

  18. End Sub
複製代碼

TOP

回復 8# 軒云熊

感謝!
這個程式OK了

TOP

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

TOP

        靜思自在 : 閒人無樂趣,忙人無是非。
返回列表 上一主題