-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