-1
この機能は私のシステム全体を遅くしています。以下のExcel VBAマクロ機能のスピードアップ方法は？
Sub Projection(RegionStr As String, Noofmonths As Integer, Cc1 As String, Cc2 As String)
Dim wkb As Workbook
Dim wks, wks2 As Worksheet
Dim cycle1_mon, cycle1_yr, cycle2_yr, src1, src2, cycle2_mon As String
Dim month, factor, fc_start, missed_month, miss, count As Integer
Dim fc_mon, inc, diffr, row_num_var3, y1, m1, m2, diffa, currentRow As Integer
Dim i_cycle1_mon, i_cycle2_mon, i_cycle1_yr, i_cycle2_yr As Integer
'looping variables
Dim loop_var, row_num_var1, row_num_var2 As Integer
Set wkb = ActiveWorkbook
'Extract Month and year for user provided START-DATE & END-DATE
cycle1_mon = Mid(Cc1, 5, 2)
cycle1_yr = Left(Cc1, 4)
cycle2_yr = Left(Cc2, 4)
cycle2_mon = Mid(Cc2, 5, 2)
i_cycle1_mon = CInt(cycle1_mon)
i_cycle1_yr = CInt(cycle1_yr)
i_cycle2_yr = CInt(cycle2_yr)
i_cycle2_mon = CInt(cycle2_mon)
strtd_with_err_flg = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False
On Error Resume Next
Set wks = ActiveWorkbook.Sheets("SUMMARY_TBL")
wks.Select
If Err Then
gdivolume.Status.Caption = "Missing Tab -> Summary_Tbl"
Exit Sub
Else
gdivolume.Status.Caption = "Updating Forecast Rows "
End If
On Error GoTo Err_Exit:
wks.cells.EntireColumn.AutoFit
'cleaning already existing data in Forecast sheet
ActiveWorkbook.Sheets("Forecast").Visible = True
Set wks2 = ActiveWorkbook.Sheets("Forecast")
wks2.Select
gdivolume.Status.Caption = "Cleaning the Forecast Tab"
wks2.cells.Select
Selection.Delete Shift:=xlUp
Selection.Delete Shift:=xlUp
Selection.Delete Shift:=xlDown
Selection.Delete Shift:=xlToRight
currentRow = 1
For row_num_var2 = 2 To wks.UsedRange.Rows.count
src1 = Sheets("Summary_Tbl").range("A" & row_num_var2)
src2 = Sheets("Summary_Tbl").range("A" & row_num_var2 + 1)
m1 = Sheets("Summary_Tbl").range("E" & row_num_var2)
m2 = Sheets("Summary_Tbl").range("E" & row_num_var2 + 1)
'once Summary_tab records are over then exit loop
If src1 = "" Then Exit For
currentRow = wks2.UsedRange.Rows.count
If row_num_var2 = 2 Then
month = CInt(m1)
Call start_miss(row_num_var2, month, i_cycle1_mon, i_cycle1_yr, wks2, wkb, src1)
End If
currentRow = wks2.UsedRange.Rows.count + 2
If src1 = src2 Then
If strtd_with_err_flg And row_num_var2 = 2 Then
currentRow = wks2.UsedRange.Rows.count + 1
End If
wkb.Sheets("Summary_Tbl").Rows(row_num_var2).EntireRow.Copy
wks2.range("A" & currentRow).Select
wks2.Paste
'wkb.Sheets("Forecast").range("A" & currentRow).Select
'wkb.Sheets("Forecast").Paste
Selection.NumberFormat = "@"
'Sheets("Summary_Tbl").range("A" & row_num_var2 & ":F" & row_num_var2).Copy Destination:=Sheets("Forecast").range("A" & row_num_var2)
'wkb.Sheets("Forecast").range("E" & currentRow & ":F" & currentRow).Select
wks2.range("E" & currentRow & ":F" & currentRow).Select
Selection.NumberFormat = "@"
'assigning SLR factor as 10 for the first month in the actuals range for all source code
If i_cycle1_mon = wkb.Sheets("Summary_tbl").range("E" & row_num_var2).Value Then
'wkb.Sheets("Forecast").range("G" & currentRow).Value = 10
wks2.range("G" & currentRow).Value = 10
End If
If i_cycle1_mon < wkb.Sheets("Summary_tbl").range("E" & row_num_var2).Value Then
diffa = wkb.Sheets("Summary_tbl").range("E" & row_num_var2).Value - i_cycle1_mon
'wkb.Sheets("Forecast").range("G" & currentRow).Value = (diffa + 1) * 10
wks2.range("G" & currentRow).Value = (diffa + 1) * 10
If wkb.Sheets("Forecast").range("G" & currentRow).Value <= 0 Then
'wkb.Sheets("Forecast").range("G" & currentRow).Value = wkb.Sheets("Forecast").range("G" & currentRow).Value + 120
wks2.range("G" & currentRow).Value = wks2.range("G" & currentRow).Value + 120
End If
ElseIf i_cycle1_mon > wkb.Sheets("Summary_tbl").range("E" & row_num_var2).Value Then
diffa = i_cycle1_mon - wkb.Sheets("Summary_tbl").range("E" & row_num_var2).Value
'wkb.Sheets("Forecast").range("G" & currentRow).Value = ((diffa + 1) * 10) + wkb.Sheets("Summary_tbl").range("G" & row_num_var2 - 1).Value
wks2.range("G" & currentRow).Value = ((diffa + 1) * 10) + wkb.Sheets("Summary_tbl").range("G" & row_num_var2 - 1).Value
End If
m1 = Sheets("Summary_Tbl").range("E" & row_num_var2)
y1 = Sheets("Summary_Tbl").range("F" & row_num_var2)
m2 = Sheets("Summary_Tbl").range("E" & row_num_var2 + 1)
'check if the month values are continuous in the Summary_tbl tab and identify rows which are missed in between
If m2 <> CInt(m1) + 1 Then
'if new rows has to be inserted after december month
If m1 = 12 Then
If m2 < m1 Then
missed_month = m2 - 1
If missed_month > 0 Then
'insert the missed rows and set the values for all columns in the newly inserted missed rows
For loop_var = 1 To missed_month
Dim row_num As Integer
row_num = wks2.UsedRange.Rows.count + 2
range("A" & row_num).EntireRow.Insert
wkb.Sheets("Summary_Tbl").Rows(row_num - 1).EntireRow.Copy
'wkb.Sheets("Forecast").range("A" & row_num).Select
'wkb.Sheets("Forecast").Paste
wks2.range("A" & row_num).Select
wks2.Paste
Selection.NumberFormat = "@"
'wkb.Sheets("Forecast").range("B" & row_num).Value = 0
wks2.range("B" & row_num).Value = 0
'wkb.Sheets("Forecast").range("E" & row_num).Select
Selection.NumberFormat = "@"
'wkb.Sheets("Forecast").range("E" & row_num).Value = loop_var
wks2.range("E" & row_num).Value = loop_var
'If wkb.Sheets("Forecast").range("E" & row_num).Value < 10 Then
If wks2.range("E" & row_num).Value < 10 Then
'wkb.Sheets("Forecast").range("E" & row_num).Value = 0 & wkb.Sheets("Forecast").range("E" & row_num).Value
wks2.range("E" & row_num).Value = 0 & wks2.range("E" & row_num).Value
End If
'wkb.Sheets("Forecast").range("A" & row_num).Select
wks2.range("A" & row_num).Select
Selection.NumberFormat = "@"
'wkb.Sheets("Forecast").range("A" & row_num).Value = wkb.Sheets("Forecast").range("A" & row_num - 1).Value
'wkb.Sheets("Forecast").range("D" & row_num).Value = "ACTUAL PROD VOLUME"
'wkb.Sheets("Forecast").range("C" & row_num).Value = "DUMMY"
'wkb.Sheets("Forecast").range("G" & row_num).Value = wkb.Sheets("Forecast").range("G" & row_num - 1).Value + (10)
'wkb.Sheets("Forecast").range("F" & row_num).Select
'Selection.NumberFormat = "@"
'wkb.Sheets("Forecast").range("F" & row_num).Value = y1 + 1
wks2.range("A" & row_num).Value = wkb.Sheets("Forecast").range("A" & row_num - 1).Value
wks2.range("D" & row_num).Value = "ACTUAL PROD VOLUME"
wks2.range("C" & row_num).Value = "DUMMY"
wks2.range("G" & row_num).Value = wkb.Sheets("Forecast").range("G" & row_num - 1).Value + (10)
wks2.range("F" & row_num).Select
Selection.NumberFormat = "@"
wks2.range("F" & row_num).Value = y1 + 1
Next loop_var
End If
End If
End If
'if new rows has to be inserted after any month other than december
If m1 <> 12 Then
If m1 < m2 Then
missed_month = m2 - m1 - 1
If missed_month > 0 Then
For loop_var = 1 To missed_month
Dim row_num1 As Integer
row_num1 = wks2.UsedRange.Rows.count + 2
range("A" & row_num1).EntireRow.Insert
' wkb.Sheets("Summary_Tbl").Rows(row_num1 - 1).EntireRow.Copy
' wkb.Sheets("Forecast").range("A" & row_num1).Select
' wkb.Sheets("Forecast").Paste
' Selection.NumberFormat = "@"
' wkb.Sheets("Forecast").range("B" & row_num1).Value = 0
' wkb.Sheets("Forecast").range("E" & row_num1).Select
' Selection.NumberFormat = "@"
' wkb.Sheets("Forecast").range("E" & row_num1).Value = wkb.Sheets("Forecast").range("E" & row_num1 - 1).Value + (1)
wkb.Sheets("Summary_Tbl").Rows(row_num1 - 1).EntireRow.Copy
wks2.range("A" & row_num1).Select
wks2.Paste
Selection.NumberFormat = "@"
wks2.range("B" & row_num1).Value = 0
wks2.range("E" & row_num1).Select
Selection.NumberFormat = "@"
wks2.range("E" & row_num1).Value = wkb.Sheets("Forecast").range("E" & row_num1 - 1).Value + (1)
' If wkb.Sheets("Forecast").range("E" & row_num1).Value < 10 Then
' wkb.Sheets("Forecast").range("E" & row_num1).Value = 0 & wkb.Sheets("Forecast").range("E" & row_num1).Value
' End If
If wks2.range("E" & row_num1).Value < 10 Then
wks2.range("E" & row_num1).Value = 0 & wkb.Sheets("Forecast").range("E" & row_num1).Value
End If
'wkb.Sheets("Forecast").range("A" & row_num1).Select
wks2.range("A" & row_num1).Select
Selection.NumberFormat = "@"
If Len(src1) = 2 Then
'wkb.Sheets("Forecast").range("A" & row_num1).Value = "0" & src1
wks2.range("A" & row_num1).Value = "0" & src1
Else
wkb.Sheets("Forecast").range("A" & row_num1).Value = src1
wks2.range("A" & row_num1).Value = src1
End If
' wkb.Sheets("Forecast").range("D" & row_num1).Value = "ACTUAL PROD VOLUME"
' wkb.Sheets("Forecast").range("C" & row_num1).Value = "DUMMY"
' wkb.Sheets("Forecast").range("G" & row_num1).Value = wkb.Sheets("Forecast").range("G" & row_num1 - 1).Value + (10)
' wkb.Sheets("Forecast").range("F" & row_num1).Select
' Selection.NumberFormat = "@"
' wkb.Sheets("Forecast").range("F" & row_num1).Value = wkb.Sheets("Forecast").range("F" & row_num1 - 1).Value
wks2.range("D" & row_num1).Value = "ACTUAL PROD VOLUME"
wks2.range("C" & row_num1).Value = "DUMMY"
wks2.range("G" & row_num1).Value = wkb.Sheets("Forecast").range("G" & row_num1 - 1).Value + (10)
wks2.range("F" & row_num1).Select
Selection.NumberFormat = "@"
wks2.range("F" & row_num1).Value = wkb.Sheets("Forecast").range("F" & row_num1 - 1).Value
Next loop_var
End If
End If
If m1 > m2 Then
miss = m1 - m2
missed_month = 12 - miss - 1
If missed_month > 0 Then
For loop_var = 1 To missed_month
Dim row_num2 As Integer
Dim mon, yr As Integer
row_num2 = wks2.UsedRange.Rows.count + 2
range("A" & row_num2).EntireRow.Insert
wkb.Sheets("Summary_Tbl").Rows(row_num2 - 1).EntireRow.Copy
wkb.Sheets("Forecast").range("A" & row_num2).Select
wkb.Sheets("Forecast").Paste
Selection.NumberFormat = "@"
wkb.Sheets("Forecast").range("B" & row_num2).Value = 0
wkb.Sheets("Forecast").range("E" & row_num2).Select
Selection.NumberFormat = "@"
wkb.Sheets("Forecast").range("G" & row_num2).Value = wkb.Sheets("Forecast").range("G" & row_num2 - 1).Value + (10)
wkb.Sheets("Forecast").range("A" & row_num2).Select
Selection.NumberFormat = "@"
If Len(src1) = 2 Then
wkb.Sheets("Forecast").range("A" & row_num2).Value = "0" & src1
Else
wkb.Sheets("Forecast").range("A" & row_num2).Value = src1
End If
wkb.Sheets("Forecast").range("D" & row_num2).Value = "ACTUAL PROD VOLUME"
wkb.Sheets("Forecast").range("C" & row_num2).Value = "DUMMY"
mon = m1 + loop_var
yr = i_cycle1_yr
If mon > 12 Then
mon = mon - 12
yr = i_cycle2_yr
End If
wkb.Sheets("Forecast").range("E" & row_num2).Value = mon
If wkb.Sheets("Forecast").range("E" & row_num2).Value < 10 Then
wkb.Sheets("Forecast").range("E" & row_num2).Value = 0 & wkb.Sheets("Forecast").range("E" & row_num2).Value
End If
wkb.Sheets("Forecast").range("F" & row_num2).Select
Selection.NumberFormat = "@"
wkb.Sheets("Forecast").range("F" & row_num2).Value = yr
Next loop_var
End If
End If
End If
End If
End If
inc = 1
'if we have reached the last record containing data in Summary_tbl tab
If src2 = "" Then
wkb.Sheets("Summary_Tbl").Rows(row_num_var2).EntireRow.Copy
wkb.Sheets("Forecast").range("A" & currentRow).Select
wkb.Sheets("Forecast").Paste
Selection.NumberFormat = "@"
wkb.Sheets("Forecast").range("E" & currentRow & ":F" & currentRow).Select
Selection.NumberFormat = "@"
If wkb.Sheets("Summary_tbl").range("E" & row_num_var2) > wkb.Sheets("Summary_tbl").range("E" & row_num_var2 - 1).Value Then
diffa = wkb.Sheets("Summary_tbl").range("E" & row_num_var2).Value - wkb.Sheets("Summary_tbl").range("E" & row_num_var2 - 1).Value
wkb.Sheets("Forecast").range("G" & currentRow).Value = wkb.Sheets("Forecast").range("G" & currentRow - 1).Value + (diffa * 10)
If wkb.Sheets("Forecast").range("G" & currentRow).Value <= 0 Then
wkb.Sheets("Forecast").range("G" & currentRow).Value = wkb.Sheets("Forecast").range("G" & currentRow).Value + 120
End If
End If
wkb.Sheets("Forecast").range("A" & currentRow).Value = wkb.Sheets("Forecast").range("A" & row_num_var2).Value
End If
'if we are reading the next set of data corresponding to new source code
If src1 <> src2 Then
wkb.Sheets("Summary_Tbl").Rows(row_num_var2).EntireRow.Copy
wkb.Sheets("Forecast").range("A" & currentRow).Select
wkb.Sheets("Forecast").Paste
Selection.NumberFormat = "@"
'Sheets("Summary_Tbl").range("A" & row_num_var2 & ":F" & row_num_var2).Copy Destination:=Sheets("Forecast").range("A" & row_num_var2)
wkb.Sheets("Forecast").range("E" & currentRow & ":F" & currentRow).Select
Selection.NumberFormat = "@"
month = wkb.Sheets("Summary_tbl").range("E" & row_num_var2)
If wkb.Sheets("Summary_tbl").range("E" & row_num_var2) > wkb.Sheets("Summary_tbl").range("E" & row_num_var2 - 1).Value Then
diffa = wkb.Sheets("Summary_tbl").range("E" & row_num_var2).Value - wkb.Sheets("Summary_tbl").range("E" & row_num_var2 - 1).Value
wkb.Sheets("Forecast").range("G" & currentRow).Value = wkb.Sheets("Forecast").range("G" & currentRow - 1).Value + (10)
If wkb.Sheets("Forecast").range("G" & currentRow).Value <= 0 Then
wkb.Sheets("Forecast").range("G" & currentRow).Value = wkb.Sheets("Forecast").range("G" & currentRow).Value + 120
End If
End If
Call end_miss(row_num_var2, month, i_cycle2_mon, i_cycle2_yr, wks2, wkb, src1)
wkb.Sheets("Forecast").Select
'after filling all the actuals data range for each source code as the range specified
'by user, we need to insert forecast rows
row_num_var3 = wks2.UsedRange.Rows.count + 2
For row_num_var1 = row_num_var3 To row_num_var3 + Noofmonths - 1
wkb.Sheets("Forecast").range("A" & row_num_var1).Select
Selection.NumberFormat = "@"
wkb.Sheets("Forecast").range("A" & row_num_var1).Value = Sheets("Summary_Tbl").range("A" & row_num_var2).Value
wkb.Sheets("Forecast").range("D" & row_num_var1).Value = "PROD SOURCE - FORECASTED VOLUME "
fc_mon = i_cycle2_mon + inc
'wkb.Sheets("Forecast").range("E" & row_num_var1).Value = fc_mon
If fc_mon < 10 Then
wkb.Sheets("Forecast").range("E" & row_num_var1).Value = 0 & wkb.Sheets("Forecast").range("E" & row_num_var1).Value
End If
wkb.Sheets("Forecast").range("E" & row_num_var1).Value = fc_mon
inc = inc + 1
If i_cycle2_mon < fc_mon Then
diffr = fc_mon - i_cycle2_mon
factor = 10 * diffr
wkb.Sheets("Forecast").range("G" & row_num_var1).Value = 130 + factor
End If
wkb.Sheets("Forecast").range("F" & row_num_var1).Select
Selection.NumberFormat = "@"
wkb.Sheets("Forecast").range("F" & row_num_var1).Value = i_cycle2_yr
If fc_mon > 12 Then
fc_mon = fc_mon - 12
wkb.Sheets("Forecast").range("E" & row_num_var1).Value = fc_mon
wkb.Sheets("Forecast").range("F" & row_num_var1).Value = i_cycle2_yr + 1
End If
If fc_mon < 10 Then
wkb.Sheets("Forecast").range("E" & row_num_var1).Value = 0 & wkb.Sheets("Forecast").range("E" & row_num_var1).Value
End If
Next row_num_var1
row_num_var3 = wks2.UsedRange.Rows.count + 2
Dim fcst As Integer
For fcst = row_num_var3 - Noofmonths To row_num_var3 - 1
If fcst = row_num_var3 - Noofmonths Then
Call SLR_max(row_num_var3 - Noofmonths, Noofmonths - 1)
Call AverageDeviation(row_num_var3 - Noofmonths, Noofmonths - 1)
Call Forecast(row_num_var3 - Noofmonths, Noofmonths - 1)
ElseIf fcst <> row_num_var3 - Noofmonths Then
Call SLR_max(fcst, Noofmonths - 1)
Call Forecast(fcst, Noofmonths - 1)
End If
Next fcst
month = CInt(m2)
Call start_miss(row_num_var2, month, i_cycle1_mon, i_cycle1_yr, wks2, wkb, src2)
End If
Next row_num_var2
Call CreateHeader
Call Delete_EntireColumn
Call Trim_Format
Call pivot_generate
ActiveWorkbook.Sheets("Forecast").Visible = False
gdivolume.Forecast.BackColor = vbGreen
gdivolume.RefreshPivot.Enabled = True
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True
Exit Sub
Err_Exit:
Debug.Print "Err: -> " & Err.Description
gdivolume.Forecast.BackColor = vbRed
End Sub