我有一個包含多個日期和值系列的范圍
輸入
輸出
我需要這個輸出，一系列日期（使用輸入中的最小日期和最大日期）。
如果輸出日期與系列的輸入日期匹配，則設定這一天的值，如果沒有設定為 0。我嘗試了所有型別的回圈，但我有 40 個系列的日期和值（80 列 x 2000 行），我可以不要快速得到任何東西。
uj5u.com熱心網友回復：
請測驗下一個代碼。您必須注意分析范圍中的格式與構建范圍 ( dd/mm/yyyy)中的格式相同。它在另一個作業表 ( sh1) 中回傳處理后的陣列。我用了下一張紙。如果在您的情況下它是空的，您可以按原樣使用代碼。第一行不能有其他記錄，除了最后一個Valuex。代碼可以適應搜索這種頭型別，但不是解決方案的物件：
Sub CentralizeDateValues()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, rngD As Range, lastCol As Long, lastColL As String
Dim arrD1, arrD2, arrGen, minD As Date, maxD As Date, i As Long, j As Long
Dim arrOddCols, arrCols, strCols As String, NoD As Long, mtch, col As Long, StartTime As Date
Set sh = ActiveSheet
Set sh1 = sh.Next 'use here the sheet you need (where to return the processed range)
lastR = sh.UsedRange.rows.Count 'last row
lastCol = sh.cells(1, sh.Columns.Count).End(xlToLeft).Column 'last column
'extract the odd columns number in an array:
arrOddCols = Evaluate("TRANSPOSE(ROW(1:" & lastCol / 2 & ")*2-1)")
Debug.Print Join(arrOddCols, "|"): 'just to visually check it. Comment the line after understanding what the above line does
'obtain the columns letters array:
ReDim arrCols(1 To UBound(arrOddCols))
For i = 1 To UBound(arrOddCols)
arrCols(i) = Split(cells(1, arrOddCols(i)).Address, "$")(1)
Next i
strCols = Join(arrCols, "1,") & "1": Debug.Print strCols 'just to visually check it.
Set rngD = Intersect(sh.UsedRange, sh.Range(strCols).EntireColumn) ' build the range where to match max/min dates
minD = WorksheetFunction.min(rngD)
maxD = WorksheetFunction.Max(rngD)
NoD = maxD - minD 1 'number the days in the range betweenthe min and max dates
'build a continuous date array from min to max:
arrD1 = Evaluate("TEXT(DATE(" & Year(minD) & "," & month(minD) & ",row(" & Day(minD) & ":" & NoD & ")),""dd/mm/yyyy"")")
Debug.Print Join(Application.Transpose(arrD1), "|") 'just to visually check it.
arrD2 = arrD1 'clone the built dates array
ReDim Preserve arrD2(1 To UBound(arrD1), 1 To UBound(arrCols) 1) 'add the necessary columns for Values
StartTime = Timer 'start the timer to count the time spent by the following code.
arrGen = sh.Range("A2", sh.cells(lastR, lastCol)).Value: col = 1
For i = 1 To UBound(arrGen)
For j = 1 To UBound(arrGen, 2) - 1 Step 2 'iterate from two to two columns to check dates (as string) and extract values
If arrGen(i, j) <> "" Then
col = col 1
mtch = Application.match(CStr(arrGen(i, j)), arrD1, True)
If IsNumeric(mtch) Then
arrD2(mtch, col) = arrGen(i, j 1)
Else
arrD2(mtch, col) = "strange..." 'the code reaches this line only if a mistake is in the Dates range...
End If
End If
Next j
col = 1 'reinitialize the variable to set the column where the value to be placed
Next i
'drop the processed array content at once
sh1.Range("A2").Resize(UBound(arrD2), UBound(arrD2, 2)).Value = arrD2
Sub CentralizeDateLongValues()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, rngD As Range, lastCol As Long, lastColL As String
Dim arrD1, arrD2, arrGen, minD As Date, maxD As Date, i As Long, j As Long
Dim arrOddCols, arrCols, strCols As String, NoD As Long, mtch, col As Long, StartTime As Date
Set sh = ActiveSheet
Set sh1 = sh.Next 'use here the sheet you need (where to return the processed range)
lastR = sh.UsedRange.rows.Count 'last row
lastCol = sh.cells(1, sh.Columns.Count).End(xlToLeft).Column 'last column
'extract the odd columns number in an array:
arrOddCols = Evaluate("TRANSPOSE(ROW(1:" & lastCol / 2 & ")*2-1)")
Debug.Print Join(arrOddCols, "|"): 'just to visually check it. Comment the line after understanding what the above line does
'obtain the columns letters array:
ReDim arrCols(1 To UBound(arrOddCols))
For i = 1 To UBound(arrOddCols)
arrCols(i) = Split(cells(1, arrOddCols(i)).Address, "$")(1)
Next i
strCols = Join(arrCols, "1,") & "1": Debug.Print strCols 'just to visually check it.
Set rngD = Intersect(sh.UsedRange, sh.Range(strCols).EntireColumn) ' build the range where to match max/min dates
minD = WorksheetFunction.min(rngD)
maxD = WorksheetFunction.Max(rngD)
NoD = maxD - minD 1 'number the days in the range betweenthe min and max dates
'build a continuous date array from long numbers, corespondent to min and max dates:
arrD1 = Evaluate("row(" & CLng(minD) & ":" & CLng(maxD) & ")")
'Debug.Print Join(Application.Transpose(arrD1), "|"): 'Stop
arrD2 = arrD1 ''clone the built dates arary
ReDim Preserve arrD2(1 To UBound(arrD1), 1 To UBound(arrCols) 1) 'add the necessary columns for Values
StartTime = Timer 'start the timer to count the time spent by the following code.
arrGen = sh.Range("A2", sh.cells(lastR, lastCol)).Value2: col = 1
For i = 1 To UBound(arrGen)
For j = 1 To UBound(arrGen, 2) - 1 Step 2 'iterate from two to two columns to check dates (as string) and extract values
If arrGen(i, j) <> "" Then
col = col 1
mtch = Application.match(arrGen(i, j), arrD1, True)
If IsNumeric(mtch) Then
arrD2(mtch, col) = arrGen(i, j 1)
Else
arrD2(mtch, col) = "strange..." 'the code reaches this line only if a mistake is in the Dates range...
End If
End If
Next j
col = 1 'reinitialize the variable to set the column where the value to be placed
Next i
'drop the processed array content at once
With sh1.Range("A2").Resize(UBound(arrD2), UBound(arrD2, 2))
.Value2 = arrD2
.Columns(1).NumberFormat = "dd/mm/yyyy"
End With
'put headers:
Dim arrHd: arrHd = Application.Transpose(Evaluate("row(1:" & UBound(arrD2, 2) - 1 & ")"))
arrHd = Split("Date|Value" & Join(arrHd, "|Value"), "|")
sh1.Range("A1").Resize(1, UBound(arrHd) 1).Value = arrHd: sh1.Activate
MsgBox "Ready..." & vbCrLf & _
" (" & Format(Timer - StartTime, "00.00") & " seconds)"
End Sub
End Sub
它在下一張表的“A1”中回傳標題，并在“A2”中回傳已處理的陣列。
請在測驗后發送一些反饋。我很好奇大范圍需要多少。我在小范圍內對其進行了測驗，但解決方案必須在任何范圍內運行......
編輯：
請測驗以下版本。它使用一個Long數字陣列，對應于必要的日期范圍。這允許使用value2創建全域陣列，這允許（稍微）更快的迭代并且不需要CStr轉換。也不依賴日期格式：
Sub CentralizeDateLongValues()
Dim sh As Worksheet, sh1 As Worksheet, lastR As Long, rngD As Range, lastCol As Long, lastColL As String
Dim arrD1, arrD2, arrGen, minD As Date, maxD As Date, i As Long, j As Long
Dim arrOddCols, arrCols, strCols As String, NoD As Long, mtch, col As Long, StartTime As Date
Set sh = ActiveSheet
Set sh1 = sh.Next 'use here the sheet you need (where to return the processed range)
lastR = sh.UsedRange.rows.Count 'last row
lastCol = sh.cells(1, sh.Columns.Count).End(xlToLeft).Column 'last column
'extract the odd columns number in an array:
arrOddCols = Evaluate("TRANSPOSE(ROW(1:" & lastCol / 2 & ")*2-1)")
Debug.Print Join(arrOddCols, "|"): 'just to visually check it. Comment the line after understanding what the above line does
'obtain the columns letters array:
ReDim arrCols(1 To UBound(arrOddCols))
For i = 1 To UBound(arrOddCols)
arrCols(i) = Split(cells(1, arrOddCols(i)).Address, "$")(1)
Next i
strCols = Join(arrCols, "1,") & "1": Debug.Print strCols 'just to visually check it.
Set rngD = Intersect(sh.UsedRange, sh.Range(strCols).EntireColumn) ' build the range where to match max/min dates
minD = WorksheetFunction.min(rngD)
maxD = WorksheetFunction.Max(rngD)
NoD = maxD - minD 1 'number the days in the range betweenthe min and max dates
'build a continuous date array from long numbers, corespondent to min and max dates:
arrD1 = Evaluate("row(" & CLng(minD) & ":" & CLng(maxD) & ")")
'Debug.Print Join(Application.Transpose(arrD1), "|"): 'Stop
arrD2 = arrD1 ''clone the built dates arary
ReDim Preserve arrD2(1 To UBound(arrD1), 1 To UBound(arrCols) 1) 'add the necessary columns for Values
StartTime = Timer 'start the timer to count the time spent by the following code.
arrGen = sh.Range("A2", sh.cells(lastR, lastCol)).Value2: col = 1
For i = 1 To UBound(arrGen)
For j = 1 To UBound(arrGen, 2) - 1 Step 2 'iterate from two to two columns to check dates (as string) and extract values
If arrGen(i, j) <> "" Then
col = col 1
mtch = Application.match(arrGen(i, j), arrD1, True)
If IsNumeric(mtch) Then
arrD2(mtch, col) = arrGen(i, j 1)
Else
arrD2(mtch, col) = "strange..." 'the code reaches this line only if a mistake is in the Dates range...
End If
End If
Next j
col = 1 'reinitialize the variable to set the column where the value to be placed
Next i
'drop the processed array content at once
Dim rngBlank As Range
With sh1.Range("A2").Resize(UBound(arrD2), UBound(arrD2, 2))
.Value2 = arrD2
.Columns(1).NumberFormat = "dd/mm/yyyy"
.EntireColumn.AutoFit
.Borders(xlEdgeLeft).Weight = xlThin
.Borders(xlEdgeTop).Weight = xlThin
.Borders(xlEdgeBottom).Weight = xlThin
.Borders(xlEdgeRight).Weight = xlThin
.Borders(xlInsideVertical).Weight = xlThin
.Borders(xlInsideHorizontal).Weight = xlThin
.BorderAround Weight:=xlThick
On Error Resume Next 'for the case (even imporbable) that no any blank cell will exist...
Set rngBlank = .SpecialCells(xlCellTypeBlanks)
On Error GoTo 0
End With
If Not rngBlank Is Nothing Then rngBlank.Value = 0
'put headers:
Dim arrHd: arrHd = Application.Transpose(Evaluate("row(1:" & UBound(arrD2, 2) - 1 & ")"))
arrHd = Split("Date|Value" & Join(arrHd, "|Value"), "|")
With sh1.Range("A1").Resize(1, UBound(arrHd) 1)
.Value = arrHd
.Font.Bold = True
.EntireColumn.AutoFit
.Borders(xlInsideVertical).Weight = xlThin
.BorderAround Weight:=xlThick
End With
sh1.Activate
MsgBox "Ready..." & vbCrLf & _
" (" & Format(Timer - StartTime, "00.00") & " seconds)"
End Sub
請在測驗后發送一些反饋...
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/405382.html
標籤：