none
マクロを実行するたびに、シートの容量が大きくなる RRS feed

  • 質問

  • Windows10上でExcel2016を利用して、社印使用簿を作成しております。

    社印使用簿には、
    (1)下記の「A使用簿作成」マクロを実行して、「社印使用簿」シートをコピーして、別シートに作成日の使用簿を作成する。
    (2)上記(1)の作業完了後、下記の「B記載クリア」マクロを実行して、記載をクリアする。
    といったマクロが組み込まれています。

    ところが、利用を繰り返すたびに、「社印使用簿」シートの容量がなぜか大きくなり、動作が重くなってしまいます。
    記載をすべてクリアしても、シートは重いままです。

    原因、対策があれば、ご教示していただけないでしょうか?
    よろしくお願いします。


    Sub A使用簿作成()

        Dim sakuseibi As Date

      'T1セルに、作成日を入力する。
        sakuseibi = Sheets("社印使用簿").Range("T1").Value

        Dim rc As VbMsgBoxResult
        rc = MsgBox("社印使用簿を作成してもよろしいですか?", vbYesNo)

        If rc = vbYes And Sheets("社印使用簿").Range("T1").Value = "" Then

        MsgBox "作成日(S1セル)が空白です。処理を中止します。"

        ElseIf rc = vbYes And Not Sheets("社印使用簿").Range("T1").Value = "" Then

      '記入のある行以外を、オートフィルタで隠す。
        Worksheets("社印使用簿").Copy After:=Worksheets(1)
        ActiveSheet.Range("$J$8:$N109").AutoFilter Field:=5, Criteria1:="<>"

        ActiveSheet.Name = Format(sakuseibi, "yyyymmdd")

        ActiveSheet.Tab.ColorIndex = xlNone

        '不要な図形を、クリアする。
        ActiveSheet.Shapes.Range(Array("Rounded Rectangle 7")).Select
        Selection.Delete
        ActiveSheet.Shapes.Range(Array("Rounded Rectangle 8")).Select
        Selection.Delete
        ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True

        Sheets("社印使用簿").Select
        Range("C9").Select
        ActiveSheet.Unprotect

        Else

         MsgBox "処理を中止します。"

        End If

    End Sub

    Sub B記載のクリア()

        Dim rc As VbMsgBoxResult
        rc = MsgBox("「社印使用簿」をクリアしてもよろしいですか?", vbYesNo)

        If rc = vbYes Then

        Sheets("社印使用簿").Select
        ActiveSheet.Unprotect
        Range("T1").Select
        Selection.ClearContents
          If ActiveSheet.FilterMode Then
           ActiveSheet.ShowAllData
          End If

      '「B110:M110」セルにある記載をコピーして、貼り付けることで記載をクリアする。
        Range("B110:M110").Select
        Selection.Copy
        Range("B10:M109").Select
        Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Range("B110:M110").Select
        Selection.Copy
        Range("B10:M109").Select
            Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        Application.CutCopyMode = False

      '行の高さが変わってしまうことがあるので、そろえる。
        Range("B10:M110").Select
        Selection.RowHeight = 37.5

        Range("C10").Select

        Else

         MsgBox "処理を中止します。"

        End If

    End Sub

    2020年11月25日 23:48