Question

我有@ScottCraner创建的以下代码，该代码将本月每个星期五的日期填充到单元格Q8：Q12中。

Sub myFri()
Dim OArr(1 To 5, 1 To 1) As Variant
Dim k As Long
k = 1
Dim i As Long
For i = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
    If Weekday(i, vbSunday) = 7 Then
        OArr(k, 1) = i
        k = k + 1
    End If
Next i

If k = 5 Then OArr(k, 1) = "-"

Worksheets("Sheet1").Range("Q8:Q12").Value = OArr
Worksheets("Sheet1").Range("Q8:Q12").NumberFormat = "mm/dd/yyyy"
End Sub

我已对此进行了调整，以尝试将范围设置为工作表的不同部分。香港专业教育学院做到这一点，如下所示：

Private Sub DateRangePayer1()

Dim rng1, rng2, rng3, rng4, UnionRange As Range

Set rng1 = Range("Q8:Q12")
Set rng2 = Range("T8:T12")
Set rng3 = Range("Q16:Q20")
Set rng4 = Range("T16:T20")

Set UnionRange = Union(rng1, rng2, rng3, rng4)


    Dim OArr(1 To 5, 1 To 1) As Variant
    Dim k As Long
    k = 1
    Dim i As Long
    For i = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
        If Weekday(i, vbSunday) = 6 Then
            OArr(k, 1) = i
            k = k + 1
        End If
    Next i

    If k = 5 Then OArr(k, 1) = "-"

    UnionRange.Value = OArr
    UnionRange.NumberFormat = "dd-mmmm"


End Sub

不幸的是，它当前无法按预期运行，并使用以下格式填充单元格：

它完美地填充了Q8：Q12和Q16：Q20范围，但是，当填充T行时，它仅循环通过本月的第一个星期五。

到目前为止，谢谢大家的帮助。你们都提供了令人惊讶的帮助，感谢您的所有宝贵时间。特别感谢@ScottCraner对我到目前为止提交的所有内容的所有帮助。

Answer 1

根据吉普（Jeeped）的建议，我将联合范围（Union Range）替换为个人参考。代码更改如下。如果有更有效/更整洁的方法，我想知道：

Private Sub DateRangePayer1()

'Credit to @Pᴇʜ for pointing out the Array flaw. Corrected this.
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range

Set rng1 = Range("Q8:Q12")
Set rng2 = Range("T8:T12")
Set rng3 = Range("Q16:Q20")
Set rng4 = Range("T16:T20")



    Dim OArr(1 To 5, 1 To 1) As Variant
    Dim k As Long
    k = 1
    Dim i As Long
    For i = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
        If Weekday(i, vbSunday) = 6 Then
            OArr(k, 1) = i
            k = k + 1
        End If
    Next i

    If k = 5 Then OArr(k, 1) = "-"

    rng1.Value = OArr
    rng1.NumberFormat = "dd-mmmm"
    rng2.Value = OArr
    rng2.NumberFormat = "dd-mmmm"
    rng3.Value = OArr
    rng3.NumberFormat = "dd-mmmm"
    rng4.Value = OArr
    rng4.NumberFormat = "dd-mmmm"


End Sub

Answer 2

这样的数组不能填充不连续的并集范围。最好使用5个数组或一个数组切成碎片或遍历合并范围的区域。

Private Sub dateRangePayer1()

    Dim unionRange As Range, uRng As Range
    Dim d As Long, k As Long

    Set unionRange = Worksheets("sheet8").Range("Q8:Q12, T8:T12, Q16:Q20, T16:T20")
    'Set unionRange = ActiveSheet.Range("Q8:Q12, T8:T12, Q16:Q20, T16:T20") deals with the active sheet 

    ReDim OArr(1 To 5, 1 To 1) As Variant

    For d = DateSerial(Year(Date), Month(Date), 1) To DateSerial(Year(Date), Month(Date) + 1, 0)
        If Weekday(d, vbSunday) = 6 Then
            k = k + 1
            OArr(k, 1) = d
        End If
    Next d

    If k = 4 Then OArr(k + 1, 1) = "-"

    For Each uRng In unionRange.Areas
        uRng.Value = OArr
        uRng.NumberFormat = "dd-mmmm"
    Next uRng


End Sub

Excel VBA：设置范围联合的问题

2 个答案: