EXCEL VBA 早く処理をする

質問

よろしくお願いします
下の構文を標準モジュールに書き込み、callで実行しているのですが
処理に時間がかかります。
処理を早くする方法と構文の簡素化のご教示をお願いします。

Application.ScreenUpdating = False
For i = 1 To 12
With Worksheets(i)
.Select
LastRow = .Range("A150").End(xlUp).Row + 1
.Range("A8:G" & LastRow).Sort Key1:=Range("A8"), order1:=xlAscending
.Range("G8:G" & LastRow - 1).Formula = "=G7+E8-F8"
LastRow = .Range("A150").End(xlUp).Row + 1
.Range("A" & LastRow).Select
Dim EndRow As Long
EndRow = .Range("A" & Rows.Count).End(xlUp).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1, 3) = .Name & "合計"
Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) = Application.WorksheetFunction.Sum(Range("E7:E" & EndRow))
Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) = Application.WorksheetFunction.Sum(Range("F7:F" & EndRow))
Cells(Rows.Count, 1).End(xlUp).Offset(2, 3) = "前月繰越"
Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) = .Range("G7")
Cells(Rows.Count, 1).End(xlUp).Offset(2, 5) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(3, 4) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(3, 3) = "次月繰越"
Cells(Rows.Count, 1).End(xlUp).Offset(4, 3) = "合計"
Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) - Cells(Rows.Count, 1).End(xlUp).Offset(1, 5)
Cells(Rows.Count, 1).End(xlUp).Offset(4, 4) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4)
Cells(Rows.Count, 1).End(xlUp).Offset(4, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 5)
Cells(Rows.Count, 1).End(xlUp).Offset(1, 6) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(2, 6) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(3, 6) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(4, 6) = Cells(Rows.Count, 1).End(xlUp).Offset(0, 6)

.Range("C7").End(xlDown).Select
Selection.Offset(4, 2).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(4, 2).Borders(xlEdgeBottom).LineStyle = xlDouble
Selection.Offset(4, 3).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(4, 3).Borders(xlEdgeBottom).LineStyle = xlDouble
Selection.Offset(4, 4).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(4, 4).Borders(xlEdgeBottom).LineStyle = xlDouble

Selection.Offset(0, 2).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(0, 2).Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Offset(0, 2).Borders(xlEdgeBottom).Weight = xlThin
Selection.Offset(0, 3).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(0, 3).Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Offset(0, 3).Borders(xlEdgeBottom).Weight = xlThin
Selection.Offset(0, 4).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(0, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Offset(0, 4).Borders(xlEdgeBottom).Weight = xlThin
End With
Next i
Application.ScreenUpdating = True

回答No.1

kagakusuki · ベストアンサー

LastRowの値を求める際に、

LastRow = .Range("A150").End(xlUp).Row + 1

とA150を基点にしている事や、行番号を+1にしている事は何故なのか意味が解りません。
　全て一律に

LastRow = .Range("A" & Rows.Count).End(xlUp).Row

で処理してしまえば良いのではないでしょうか？
　処理に時間がかかる原因は、計算方法のモードが自動モードになっているため、VBAでセルの値を入力したり、書き換えたりするたびに再計算が行われるためですから、VBAのマクロ上で計算方法のモードを一旦、手動モードに切り替えてから値の書き換えを行う様にされると良いと思います。

Sub QNo9129440_EXCEL_VBA_早く処理をする()
Dim i As longe, LastRow As Long
With Application
.ScreenUpdating = False
.Calculation = xlManual
End With
For i = 1 To 12
With Worksheets(i)
LastRow = .Range("A" & Rows.Count).End(xlUp).row
.Range("A8:G" & LastRow).Sort Key1:=Range("A8"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Range("G8:G" & LastRow).FormulaR1C1 = "=R[-1]C+RC5-RC6"
With .Range("A" & LastRow)
.Offset(1, 4).Resize(3, 3).ClearContents
.Offset(1, 3) = .Parent.Name & "合計"
.Offset(2, 3) = "前月繰越"
.Offset(3, 3) = "次月繰越"
.Offset(4, 3) = "合計"
.Offset(1, 4).Resize(1, 2).FormulaR1C1 = "=SUM(R7C:R[-1]C)"
.Offset(2, 4) = .Range("G7")
.Offset(4, 5) = .Offset(2, 4)
.Offset(4, 4) = .Offset(2, 4) + .Offset(1, 4)
.Offset(3, 5) = .Offset(4, 4) - .Offset(1, 5)
.Offset(4, 6) = .Offset(0, 6)
End With
With .Range("C7").End(xlDown).Offset(0, 2).Resize(1, 3)
.Borders(xlEdgeTop).Weight = xlHairline
With .Borders(xlEdgeBottom)
.Weight = xlThin
.LineStyle = xlContinuous
End With
With .Offset(4)
.Borders(xlEdgeTop).Weight = xlHairline
.Borders(xlEdgeBottom).LineStyle = xlDouble
End With
End With
End With
Next i
With Application
.Calculation = xlAutomatic
.ScreenUpdating = True
End With
End Sub

補足

kagakusuki 様　早速のご教示ありがとうございます。
構文中の下記か所でエラーになります
”アプリケーション定義またはオブジェクト定義のエラーです”
恐れ入りますが、是正をお願いできないでしょうか。
どうぞよろしくお願いします。
.Range("A8:G" & LastRow).Sort Key1:=Range("A8"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

回答No.4

kagakusuki

>>下記のようにしたいのです。

>＞1月入金合計　.Offset(1, 4).Resize(1, 4).FormulaR1C1 = "=SUM(R8C:R[-1]C)"

>＞1月の出金合計　.Offset(1, 5).Resize(1, 5).FormulaR1C1 = "=SUM(R8C:R[-1]C)"

> ＞前期繰越　 .Offset(2, 4) = .Range("G7")

>＞次期繰越　.Offset(3, 5) = .Offset(0, 6)

>＞1月入金合計+前期繰越
> 　　　　.Offset(4, 4) = .Offset(1, 4) + .Offset(2, 4)

＞1月出金合計+次期繰越
> 　　　　.Offset(4, 5) = .Offset(1, 5) + .Offset(3, 5)

＞残高　 .Offset(4, 6) = .Offset(0, 6)

＞最終行の下に2重線（上線は行が増えたときに元のxlHairlineに戻すためです）　
> >　　.Offset(4, 4)から.Offset(4, 6)まで
>　　.Borders(xlEdgeTop).Weight = xlHairline
>　　.Borders(xlEdgeBottom).LineStyle = xlDouble

＞月合計の上に実線（上線は行が増えたときに元のxlHairlineに戻すためです）　
>.Offset(0, 4)から.Offset(0, 6)まで
>.Borders(xlEdgeTop).Weight = xlHairline
> .Borders(xlEdgeBottom).LineStyle = xlContinuous

　質問者様が回答No.3に対する補足コメント欄で仰っておられる事は、御質問文に書かれている「バグがあるVBA」の内容を只説明しているだけの事に過ぎません。
　質問者様が作ったVBAには条件次第でエラーが出てしまうというバグがあり、質問者様が回答No.3に対する補足コメント欄で仰っておられる事は、バグがあるやり方なのです。
　仰るようなやり方をしたために条件次第でエラーが出てしまう様な事になっている訳であり、バグがあるやり方でやろうとしても、エラーが出てしまうというバグは無くならず、再びエラーが出てしまうだけです。
　だからこそ、回答No.3において

>エラーとなってしまうセルの表示をどの様な表示に変更する様にしたいのかという事を御説明願います。

と尋ねている訳です。
　ですから、

>A8以下のセルに値が入力されていなかったり、G7セルやE列～F列のセルに文字列が入力されている場合

等の、質問者様が作ったVBAマクロでエラーが生じるような状況となった場合には、質問者様はどの様な表示にしたいのかを御教え願います。

お礼

kagakusuki 様　ご教示ありがとうございます。
申訳けありません。
下記の構文でできました。
長きに渡ってお教えいただきありがとうございました。
これからもなにとぞ、お教えいただきますようお願いします。
Private Sub OK_Click()
Dim h As Long
Dim MsgRtn As Long
Dim LastRow As Long
Dim EndRow As Long
Application.ScreenUpdating = False
If 支出.Text + 収入.Text = "" Then
MsgBox "金額が入っていません"
End If
If 摘要外.Value <> "" Then
With 摘要外
Cells(ActiveCell.Row, 4).Select
ActiveCell.Value = 摘要外.Value
End With
Else
End If
With ActiveSheet
LastRow = .Range("A150").End(xlUp).Row + 1
.Range("A8:G" & LastRow).Sort Key1:=Range("A8"), order1:=xlAscending

.Range("G8:G" & LastRow - 1).Formula = "=G7+E8-F8"
LastRow = .Range("A150").End(xlUp).Row + 1
.Range("A" & LastRow).Select
Cells(Rows.Count, 1).End(xlUp).Offset(1, 3) = " " & .Name & "合計"
EndRow = Range("A" & Rows.Count).End(xlUp).Row
Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) = Application.WorksheetFunction.Sum(Range("E7:E" & EndRow))
Cells(Rows.Count, 1).End(xlUp).Offset(1, 5) = Application.WorksheetFunction.Sum(Range("F7:F" & EndRow))
Cells(Rows.Count, 1).End(xlUp).Offset(2, 3) = " 前月繰越"
Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) = .Range("G7")
Cells(Rows.Count, 1).End(xlUp).Offset(2, 5) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(3, 4) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(3, 3) = " 次月繰越"
Cells(Rows.Count, 1).End(xlUp).Offset(4, 3) = " 合 計"
Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4) - Cells(Rows.Count, 1).End(xlUp).Offset(1, 5)
Cells(Rows.Count, 1).End(xlUp).Offset(4, 4) = Cells(Rows.Count, 1).End(xlUp).Offset(2, 4) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 4)
Cells(Rows.Count, 1).End(xlUp).Offset(4, 5) = Cells(Rows.Count, 1).End(xlUp).Offset(3, 5) + Cells(Rows.Count, 1).End(xlUp).Offset(1, 5)
Cells(Rows.Count, 1).End(xlUp).Offset(1, 6) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(2, 6) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(3, 6) = ""
Cells(Rows.Count, 1).End(xlUp).Offset(4, 6) = Cells(Rows.Count, 1).End(xlUp).Offset(0, 6)
Selection.Offset(3, 4).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(3, 4).Borders(xlEdgeBottom).LineStyle = xlDouble
Selection.Offset(3, 5).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(3, 5).Borders(xlEdgeBottom).LineStyle = xlDouble
Selection.Offset(3, 6).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(3, 6).Borders(xlEdgeBottom).LineStyle = xlDouble
Selection.Offset(-1, 4).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(-1, 4).Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Offset(-1, 4).Borders(xlEdgeBottom).Weight = xlThin
Selection.Offset(-1, 5).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(-1, 5).Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Offset(-1, 5).Borders(xlEdgeBottom).Weight = xlThin
Selection.Offset(-1, 6).Borders(xlEdgeTop).Weight = xlHairline
Selection.Offset(-1, 6).Borders(xlEdgeBottom).LineStyle = xlContinuous
Selection.Offset(-1, 6).Borders(xlEdgeBottom).Weight = xlThin
End With
LastRow = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
入力フォーム.残高.Value = ActiveSheet.Range("G" & LastRow).Value
新規摘要.Visible = False
Unload 入力フォーム
入力フォーム.Show vbModeless
Application.ScreenUpdating = True
End Sub

回答No.3

kagakusuki

>ご教示いただいた構文中の下記か所でデバックエラーになります

>>.Offset(4, 4) = .Offset(2, 4) + .Offset(1, 4)
> .Offset(3, 5) = .Offset(4, 4) - .Offset(1, 5)

　それは御質問文にある質問者様が作った構文中に元から含まれていたバグによるものです。
　質問者様の構文では、A8以下のセルに値が入力されていなかったり、G7セルやE列～F列のセルに文字列が入力されている場合にはエラーとなってしまいますので、VBAを起動させる際には、前もってA8以下のセルにも値を入力し、G7セルやE列～F列のセルには数値データを入力しておく様にして下さい。

　尚、もしバグを無くしたいという事であれば、

>A8以下のセルに値が入力されていなかったり、G7セルやE列～F列のセルに文字列が入力されている場合

等の、質問者様が作ったVBAマクロでエラーが生じるような状況となった場合には、エラーとなってしまうセルの表示をどの様な表示に変更する様にしたいのかという事を御説明願います。

補足

kagakusuki 様　ご教示ありがとうございます。
わかりにくい説明ですみません。
下記のようにしたいのです。

＞1月入金合計　.Offset(1, 4).Resize(1, 4).FormulaR1C1 = "=SUM(R8C:R[-1]C)"

＞1月の出金合計　.Offset(1, 5).Resize(1, 5).FormulaR1C1 = "=SUM(R8C:R[-1]C)"

＞前期繰越　 .Offset(2, 4) = .Range("G7")

＞次期繰越　.Offset(3, 5) = .Offset(0, 6)

＞1月入金合計+前期繰越
　　　　.Offset(4, 4) = .Offset(1, 4) + .Offset(2, 4)

＞1月出金合計+次期繰越
　　　　.Offset(4, 5) = .Offset(1, 5) + .Offset(3, 5)

＞残高　 .Offset(4, 6) = .Offset(0, 6)

＞最終行の下に2重線（上線は行が増えたときに元のxlHairlineに戻すためです）　
　　.Offset(4, 4)から.Offset(4, 6)まで
　　.Borders(xlEdgeTop).Weight = xlHairline
　　.Borders(xlEdgeBottom).LineStyle = xlDouble

＞月合計の上に実線（上線は行が増えたときに元のxlHairlineに戻すためです）　
.Offset(0, 4)から.Offset(0, 6)まで
.Borders(xlEdgeTop).Weight = xlHairline
.Borders(xlEdgeBottom).LineStyle = xlContinuous

なにとぞよろしくお願いします。

回答No.2

kagakusuki

>構文中の下記か所でエラーになります
>.Range("A8:G" & LastRow).Sort Key1:=Range("A8"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

　失礼しました。ではその部分を下記のものと差し換えて下さい。

With .Sort
With .SortFields
.Clear
.Add Key:=Range("A8"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
End With
.Header = xlGuess
.SetRange Range("A8:G" & LastRow)
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

補足

kagakusuki 様　早速のご教示ありがとうございます。
ご教示いただいた構文中の下記か所でデバックエラーになります
恐れ入りますが、再度是正をお願いできないでしょうか。
どうぞよろしくお願いします。
With .Range("A" & LastRow)
.Offset(1, 4).Resize(3, 3).ClearContents
.Offset(1, 3) = .Parent.Name & "合計"
.Offset(2, 3) = "前月繰越"
.Offset(3, 3) = "次月繰越"
.Offset(4, 3) = "合計"
.Offset(1, 4).Resize(1, 2).FormulaR1C1 = "=SUM(R7C:R[-1]C)"
.Offset(2, 4) = .Range("G7")
.Offset(4, 5) = .Offset(2, 4)
>.Offset(4, 4) = .Offset(2, 4) + .Offset(1, 4)
.Offset(3, 5) = .Offset(4, 4) - .Offset(1, 5)
.Offset(4, 6) = .Offset(0, 6)
End With