0

我正在处理日历，并试图创建一个子程序，该子程序会自动填写相应月表中一年中的每一周。周格式和内容由

 firstRange.Copy Destination:=secondRange

从隐藏的 excel 表中，然后将日期和标题与

 Call secondRange.Replace("Sometext", Weekdate)

问题是每次我使用这个函数时，我的 Excel 表格的大小都会增加大约 4KB。这不是太成问题，因为 Sub 每年只会使用一次，但在文件大小急剧增加之前，我也遇到过类似的问题，通常是在使用 VBA 删除行或列时。

有什么我需要改变的，还是我必须忍受的 Excel 的一些问题？低于完整的子（英语和德语混合）

Public Sub newYear(Optional dasJahr As Integer = 0)

    If dasJahr = 0 Then dasJahr = getYear() ' Nimmt Constant thisYear falls nichts anderes spezifiziert ist. 

    ' Auschalten von Events
    Application.EnableEvents = False

    ' Löschen der Inhalte auf den Monatsblättern
    Worksheets("Januar").Cells.ClearContents
    Worksheets("Februar").Cells.ClearContents
    Worksheets("März").Cells.ClearContents
    Worksheets("April").Cells.ClearContents
    Worksheets("Mai").Cells.ClearContents
    Worksheets("Juni").Cells.ClearContents
    Worksheets("Juli").Cells.ClearContents
    Worksheets("August").Cells.ClearContents
    Worksheets("September").Cells.ClearContents
    Worksheets("Oktober").Cells.ClearContents
    Worksheets("November").Cells.ClearContents
    Worksheets("Dezember").Cells.ClearContents

    Dim Montag As Date
    Dim Neujahr As Date: Neujahr = DateValue("1.1." & dasJahr)

    Dim hoeheWoche As Integer: hoeheWoche = 69
    Dim breiteWoche As Integer: breiteWoche = 35

    Dim wsMnt As Worksheet: Set wsMnt = Worksheets("Januar")
    Dim wsVrlg As Worksheet: Set wsVrlg = Worksheets("Vorlage")

    Dim rDst As Range, rSrc As Range
    ' Kopiervorlage als Source definieren
    Set rSrc = wsVrlg.Range(wsVrlg.Cells(1, 1), wsVrlg.Cells(hoeheWoche + 1, breiteWoche + 1))


    Montag = Neujahr - Weekday(Neujahr, vbTuesday)

    Dim wochenStartReihe As Integer: wochenStartReihe = 2

    Do While (Year(Montag) <= dasJahr)

        If getMonth(Montag - 1, dasJahr) <> getMonth(Montag, dasJahr) Then
            wochenStartReihe = 2
            Set wsMnt = Worksheets(getMonth(Montag, dasJahr))
        End If

        Set rDst = wsMnt.Range(wsMnt.Cells(wochenStartReihe, 2), wsMnt.Cells(wochenStartReihe + hoeheWoche, 2 + breiteWoche))

        ' Kopiert Inhalte und Format aus der Vorlage in das Monatsblatt
        rSrc.Copy Destination:=rDst

        ' Ersetzen der Wochentage mit Datum
        Call rDst.Replace("Woche X ausblenden", "Woche " & KWoche(Montag) & " ausblenden")
        Call rDst.Replace("Montag", Montag)
        Call rDst.Replace("Dienstag", Montag + 1)
        Call rDst.Replace("Mittwoch", Montag + 2)
        Call rDst.Replace("Donnerstag", Montag + 3)
        Call rDst.Replace("Freitag", Montag + 4)
        Call rDst.Replace("Samstag", Montag + 5)
        Call rDst.Replace("Sonntag", Montag + 6)

        ' Doppelte Auflistung der Wochen die in zwei Monaten liegen
        If (getMonth(Montag, dasJahr) <> getMonth(Montag + 6, dasJahr)) And (getMonth(Montag + 6, dasJahr) <> "Januar") Then

            Set wsMnt = Worksheets(getMonth(Montag + 6, dasJahr))
            wochenStartReihe = 2

            Set rDst = wsMnt.Range(wsMnt.Cells(wochenStartReihe, 2), wsMnt.Cells(wochenStartReihe + hoeheWoche, 2 + breiteWoche))

            rSrc.Copy Destination:=rDst

            Call rDst.Replace("Woche X ausblenden", "Woche " & KWoche(Montag) & " ausblenden")
            Call rDst.Replace("Montag", Montag)
            Call rDst.Replace("Dienstag", Montag + 1)
            Call rDst.Replace("Mittwoch", Montag + 2)
            Call rDst.Replace("Donnerstag", Montag + 3)
            Call rDst.Replace("Freitag", Montag + 4)
            Call rDst.Replace("Samstag", Montag + 5)
            Call rDst.Replace("Sonntag", Montag + 6)

        End If

        wochenStartReihe = wochenStartReihe + hoeheWoche + 3
        Montag = Montag + 7

    Loop

    ' Events wieder einschalten
    Application.EnableEvents = True

End Sub
4

0 回答 0