Reputation: 13
I have written a code that copies a template from one sheet and pastes this in a different sheet with a new variable to trigger the fuctions in the template, I currently have 115 variables that i need and it takes too long with "DoEvents" and without it excel stops responding. Is there any way to optimize the code? At the end i copy and paste as values in order to save space in the file.
Variables stored in "rng"
Code below:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Sheets("Flight FS").SelectSheets("Flight FS").Range("c1048576").Select
Selection.End(xlUp).Select
Sheets("Flight FS").Range(ActiveCell, Sheets("Flight FS").Range("C6").End(xlToRight)).Select
Selection.Clear
Dim rng As Range, cell As Range
Set rng = Sheets("Flight FS templ").Range("c45", Sheets("Flight FS
templ").Range("c45").End(xlDown))
For Each cell In rng
Sheets("Flight FS templ").Select
Sheets("Flight FS templ").Range("c6", Sheets("Flight FS
templ").Range("i40").End(xlToRight)).Select
Selection.Copy
Sheets("Flight FS").Select
Range("c1048576").Select
Selection.End(xlUp).Select
ActiveCell.Offset(rowoffset:=2, columnoffset:=0).Activate
ActiveSheet.Paste
ActiveCell.Offset(rowoffset:=1, columnoffset:=3).Activate
ActiveCell.Value = cell
DoEvents
Next cell
Application.Calculation = xlCalculationAutomatic
Sheets("Flight FS").Select
Sheets("Flight FS").Range("c1048576").Select
Selection.End(xlUp).Select
Sheets("Flight FS").Range(ActiveCell, Sheets("Flight
FS").Range("C6").End(xlToRight)).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveSheet.Range("A2").Select
Application.CutCopyMode = False
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
Upvotes: 1
Views: 107
Reputation: 54807
Select
Option Explicit
Sub GenerateData()
Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
' Reference the destination worksheet, reference the last cell,
' reference and clear the destination range and reference
' the destination last cell (see the offsets later in the code).
Dim dws As Worksheet: Set dws = wb.Worksheets("Flight FS")
Dim dCell As Range: Set dCell = dws.Cells(dws.Rows.Count, "C").End(xlUp)
Dim drg As Range ' (left-bottom, top-right)
Set drg = dws.Range(dCell, dws.Cells(6, dws.Columns.Count).End(xlToLeft))
drg.Clear
Set dCell = drg.Cells(1).Offset(-1)
' Reference the source worksheet, reference the source column range,
' reference the source range and calculate the destination offset.
Dim sws As Worksheet: Set sws = wb.Worksheets("Flight FS templ")
Dim scrg As Range
Set scrg = sws.Range("C45", sws.Cells(sws.Rows.Count, "C").End(xlUp))
Dim srg As Range
With sws.Range("C6", sws.Cells(6, sws.Columns.Count).End(xlToLeft))
Set srg = .EntireColumn.Rows("6:40")
End With
Dim drOffset As Long: drOffset = srg.Rows.Count + 1
Application.ScreenUpdating = False
' Prevent the formulas from the copied source ranges being calculated.
Application.Calculation = xlCalculationManual
' Loop through the cells of the source column range.
Dim scCell As Range
For Each scCell In scrg.Cells
dCell.Offset(1, 3).Value = scCell.Value ' this value is what the...
srg.Copy dCell.Offset(2) ' ... formula-infested source range depends on
Set dCell = dCell.Offset(drOffset) ' reference the next last cell
Next scCell
' It may take a while after turning on calculation.
Application.Calculation = xlCalculationAutomatic
' Replace the formulas with values.
Set drg = dws.Range(dCell, dws.Cells(6, dws.Columns.Count).End(xlToLeft))
drg.Copy
drg.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
' A Final Touch
dws.Range("A2").Select
Application.ScreenUpdating = True
MsgBox "Data generated.", vbInformation
End Sub
Upvotes: 1