我有一個資料集，其中需要有條件地填充其中一列。條件是，對于相同的批號，較早（且相等）的日期將填充 123ABC，而較新（且相等）的日期將填充 789XYZ。如果只有一個可用日期，則應填寫 123ABC。
我嘗試了以下代碼，但它將前 3 個單元格填充為 123ABC，其余單元格填充為 789XYZ。
請幫忙。
Dim F As Worksheet
Set F = ThisWorkbook.Worksheets("Sheet1")
Dim i As Long: i = 0
Dim j As Long
Do While F.Range("C2").Offset(i, 0) <> ""
If F.Range("A2").Offset(i, 0) = "" Then
j = 0
Do While F.Range("C2").Offset(j, 0) <> ""
If (Abs(DateDiff("d", F.Range("C2").Offset(i, 0).Value, F.Range("C2").Offset(j, 0).Value)) <= 5) And (F.Range("B2").Offset(i, 0) = F.Range("B2").Offset(j, 0)) Then
F.Range("A2").Offset(i, 0).Value = "123ABC"
Else
F.Range("A2").Offset(i, 0).Value = "789XYZ"
GoTo Next_Blank
End If
j = j 1
Loop
End If
Next_Blank:
i = i 1
Loop
End Sub
uj5u.com熱心網友回復：
請嘗試下一種方法。即使對于大范圍，它也應該非常快。它使用字典創建“Lot”唯一鍵，將值保留為最近的日期。然后它使用陣列并僅在記憶體中作業，將處理后的陣列內容放在代碼末尾：
Sub FillColumn()
Dim sh As Worksheet, lastR As Long, arr, i As Long, arrFin, dict As Object
Const beforeD As String = "123ABC", maxD As String = "789XYZ"
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last row in "B:B"
arr = sh.Range("A1:C" & lastR).value 'place the range in an array for faster iteration
'fill a dictionary with unique lots and most recent Date:
Set dict = CreateObject("scripting.Dictionary") 'set the necessary dictionary
For i = 2 To UBound(arr) 'iterate between the array row
'create dictionary unique keys with most recent Date as item:
dict(arr(i, 2)) = IIf(CDate(arr(i, 3)) > CDate(dict(arr(i, 2))), CDate(arr(i, 3)), CDate(arr(i, 3)))
Next i
arrFin = arr 'initialize arrFin as the initial one
For i = 2 To UBound(arr) 'iterate between the arr items
If CDate(arr(i, 3)) < dict(arr(i, 2)) Then 'for a Date before existing one in column B:B:
arrFin(i, 1) = beforeD 'place the string beforeD
Else
arrFin(i, 1) = maxD 'place the string maxD
End If
Next i
'drop the array content at once:
sh.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
編輯：
請測驗下一個版本，如果Date在同一“批次”中找到一個單曲，則放置“123ABC”，如您的評論中所要求的：
Sub FillColumn2()
Dim sh As Worksheet, lastR As Long, arr, i As Long, arrFin, dict As Object
Const beforeD As String = "123ABC", maxD As String = "789XYZ"
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
arr = sh.Range("A1:C" & lastR).value 'place the range in an array for faster iteration
'fill a dictionary with unique lots and most recent Date:
Set dict = CreateObject("scripting.Dictionary") 'set the necessary dictionary
Dim arrExist
For i = 2 To UBound(arr) 'iterate between the array row
'create dictionary unique keys with most recent Date as item, and False for only one Date found:
If Not dict.Exists(arr(i, 2)) Then
dict.Add arr(i, 2), Array(CDate(arr(i, 3)), False) 'False means only one Date
Else
If CDate(arr(i, 3)) > dict(arr(i, 2))(0) Then
arrExist = dict(arr(i, 2)) 'place existing dictionary item in an array (to be changed)
arrExist(0) = CDate(arr(i, 3)): arrExist(1) = True 'True means that a second graiter Date has been found
dict(arr(i, 2)) = arrExist
End If
End If
Next i
arrFin = arr 'initialize arrFin as the initial one
For i = 2 To UBound(arr) 'iterate between the arr items
If CDate(arr(i, 3)) < dict(arr(i, 2))(0) Or dict(arr(i, 2))(1) = False Then 'check also the second item array element (boolean)
arrFin(i, 1) = beforeD 'place the string beforeD, also for the case of the same date
Else
arrFin(i, 1) = maxD 'place the string maxD
End If
Next i
'drop the array content at once:
sh.Range("A1").Resize(UBound(arrFin), UBound(arrFin, 2)).value = arrFin
End Sub
A dictionary can keep any data type, but it has a peculiarity: if the dictionary item is an array it cannot be modified directly in the item. That's why the code uses arrExist to take the dictionary item, modify it and place it back.
It is also good to know that Excel keeps a Date as a Long number. That's why comparing the existing dictionary item (when empty) with a lower number would never change the item. No date less then zero can be supplied...
轉載請註明出處，本文鏈接：https://www.uj5u.com/net/451473.html