I am using the below excel which takes longtime to complete.
Usually i will have 30k records in invoice sheet and GRN sheet.
Can anyone suggest me to complete this task in faster way?
Sub CheckReturn()
Dim LastInvRow As Long
Dim LastGRNRow As Long
Dim i As Integer
Dim j As Integer
Application.Calculation = xlManual
LastInvRow = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row
LastGRNRow = Sheets("GRN").Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastInvRow
For j = 2 To LastGRNRow
If Sheets("GRN").Cells(j, 11).Value = "Customer Return" And _
Sheets("GRN").Cells(j, 3).Value = Sheets("Invoice").Cells(i, 7).Value And _
Sheets("GRN").Cells(j, 18).Value = Sheets("Invoice").Cells(i, 19).Value Then
Sheets("GRN").Cells(j, 34).Copy
Sheets("Invoice").Cells(i, 48).PasteSpecial Paste:=xlPasteValues
Sheets("GRN").Cells(j, 35).Copy
Sheets("Invoice").Cells(i, 49).PasteSpecial Paste:=xlPasteValues
Sheets("GRN").Cells(j, 36).Copy
Sheets("Invoice").Cells(i, 50).PasteSpecial Paste:=xlPasteValues
Exit For
End If
Next j
Next i
Application.Calculation = xlAutomatic
MsgBox "Completed - " & Now()
End Sub
I suggest to do direct transfer of data from one sheet to the other and turn off some applications to make it even fater. Try this one:
Sub CheckReturn()
Dim LastInvRow As Long
Dim LastGRNRow As Long
Dim i As Integer
Dim j As Integer
'turn applications off, to make the macro go faster
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlManual
LastInvRow = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row
LastGRNRow = Sheets("GRN").Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastInvRow
For j = 2 To LastGRNRow
If Sheets("GRN").Cells(j, 11).Value = "Customer Return" And _
Sheets("GRN").Cells(j, 3).Value = Sheets("Invoice").Cells(i, 7).Value And _
Sheets("GRN").Cells(j, 18).Value = Sheets("Invoice").Cells(i, 19).Value Then
Sheets("GRN").Cells(j, 34).Copy = Sheets("Invoice").Cells(i, 48)
Sheets("GRN").Cells(j, 35).Copy = Sheets("Invoice").Cells(i, 49)
Sheets("GRN").Cells(j, 36) = Sheets("Invoice").Cells(i, 50)
Exit For
End If
Next j
Next i
Application.Calculation = xlAutomatic
MsgBox "Completed - " & Now()
'turn applications back on..
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
This one should be a bit faster. Because you donĀ“t get the values of a and b each time when the for j loop begins.
Sub CheckReturn()
Dim LastInvRow As Long
Dim LastGRNRow As Long
Dim i As Integer
Dim j As Integer
Application.Calculation = xlManual
LastInvRow = Sheets("Invoice").Cells(Rows.Count, "A").End(xlUp).Row
LastGRNRow = Sheets("GRN").Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastInvRow
a=Sheets("Invoice").Cells(i, 7).Value
b=Sheets("Invoice").Cells(i, 19).Value
c=Sheets("GRN").Cells(j, 34).Value
d=Sheets("GRN").Cells(j, 35).Value
e=Sheets("GRN").Cells(j, 36).Value
For j = 2 To LastGRNRow
If Sheets("GRN").Cells(j, 11).Value = "Customer Return" And _
Sheets("GRN").Cells(j, 3).Value = a And _
Sheets("GRN").Cells(j, 18).Value = b Then
Sheets("Invoice").Cells(i, 48).Value=c
Sheets("Invoice").Cells(i, 49).Value=d
Sheets("Invoice").Cells(i, 50).Value=e
Application.Statusbar= i*j*100/LastInvRow*LastGRNRow & "%"
Exit For
End If
Next j
Next i
Application.Calculation = xlAutomatic
MsgBox "Completed - " & Now()
End Sub
The statusbar will show you the progress of your task in %.
Related
I am writing VBA code to filter images. The goal is to write a macro to lock in the photos so they do not move when I need to filter the other columns. This is the code that I have so far. I need help doing this in VBA. Thanks.
Sub getpic()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableAnimations = False
Dim url_column As Range
Dim image_column As Range
Dim rngColSelect As String
rngColSelect = ActiveCell.Column
Set url_column = Worksheets(1).UsedRange.Columns("A")
Set image_column = Worksheets(1).UsedRange.Columns(Col_Letter(ActiveCell.Column))
Dim pic As Shape
Dim i As Long
For i = 1 To url_column.Cells.Count
If Not IsError(Range(Cells(i, ActiveCell.Column), Cells(i, ActiveCell.Column))) Then
If Left(Range(Cells(i, ActiveCell.Column), Cells(i, ActiveCell.Column)), 4) = "http" Then
Range(Cells(i, ActiveCell.Column), Cells(i, ActiveCell.Column)).Select
Set pic = ActiveSheet.Shapes.AddPicture(Range(Cells(i, ActiveCell.Column), Cells(i, ActiveCell.Column)).Value _
, msoFalse, msoTrue, Range(Cells(i, ActiveCell.Column), Cells(i, ActiveCell.Column)).Left, Range(Cells(i, ActiveCell.Column), Cells(i, ActiveCell.Column)).Top, -1, -1)
pic.LockAspectRatio = msoTrue
pic.Height = 115
pic.Placement = xlMoveAnSize
Rows(i).RowHeight = 120
Columns(Col_Letter(ActiveCell.Column)).ColumnWidth = 50
End If
End If
Next
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableAnimations = True
MsgBox "Process complete!", vbOKOnly, "Completed"
End Sub
Function Col_Letter(lngCol As Long) As String
Dim vArr
vArr = Split(Cells(1, lngCol).Address(True, False), "$")
Col_Letter = vArr(0)
End Function
I have wrote a code which is working like Turtle walks. I have added Application Functions to make it faster but code has decided that he has to work slowly.
Any expert help will be appreciated.
Dim LastRowColumnA As Long
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
LastRowColumnA = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
For i = 11 To LastRowColumnA
If Sheet1.Cells(i, 1).Value <> "" Then
Cells(i, 7) = Evaluate("=INDEX(Table1!$A$1:$DP$27,MATCH($G$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A" & i & ",Table1!$6:$6,0))")
Cells(i, 8) = Evaluate("=INDEX(Table1!$A$1:$DP$27,MATCH($H$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A" & i & ",Table1!$6:$6,0))")
Cells(i, 9) = Evaluate("=INDEX(Table1!$A$1:$DP$27,MATCH($I$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A" & i & ",Table1!$6:$6,0))")
Cells(i, 10) = Evaluate("=INDEX(Table1!$A$1:$DP$27,MATCH($J$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A" & i & ",Table1!$6:$6,0))")
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End If
Next
second approach.
Dim LastRowColumnA As Long
LastRowColumnA = Sheet1.Cells(Rows.Count, 4).End(xlUp).Row
Sheet1.Range("G10").FormulaArray = _
"=IFERROR(INDEX(Table1!R1C1:R27C120,MATCH(R9C7&R4C5,Table1!C5&Table1!C6,0),MATCH(RC[-6],Table1!R6,0)), """")"
Sheet1.Range("G10").AutoFill Destination:=Sheet1.Range("G10:G" & LastRowColumnA), Type:=xlFillDefault
Sheet1.Range("H10").FormulaArray = _
"=IFERROR(INDEX(Table1!R1C1:R27C120,MATCH(R9C8&R4C5,Table1!C5&Table1!C6,0),MATCH(RC[-7],Table1!R6,0)), """")"
Sheet1.Range("H10").AutoFill Destination:=Sheet1.Range("H10:H" & LastRowColumnA), Type:=xlFillDefault
Sheet1.Range("I10").FormulaArray = _
"=IFERROR(INDEX(Table1!R1C1:R27C120,MATCH(R9C9&R4C5,Table1!C5&Table1!C6,0),MATCH(RC[-8],Table1!R6,0)), """")"
Sheet1.Range("I10").AutoFill Destination:=Sheet1.Range("I10:I" & LastRowColumnA), Type:=xlFillDefault
Sheet1.Range("J10").FormulaArray = _
"=IFERROR(INDEX(Table1!R1C1:R27C120,MATCH(R9C9&R4C5,Table1!C5&Table1!C6,0),MATCH(RC[-9],Table1!R6,0)), """")"
Sheet1.Range("J10").AutoFill Destination:=Sheet1.Range("J10:J" & LastRowColumnA), Type:=xlFillDefault
Formulas of First Cells which has been converted to code.
=IFERROR(INDEX(Table1!$A$1:$DP$27,MATCH($G$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A10,Table1!$6:$6,0)), "")
=IFERROR(INDEX(Table1!$A$1:$DP$27,MATCH($H$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A10,Table1!$6:$6,0)), "")
=IFERROR(INDEX(Table1!$A$1:$DP$27,MATCH($I$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A10,Table1!$6:$6,0)), "")
=IFERROR(INDEX(Table1!$A$1:$DP$27,MATCH($J$9&$E$4,Table1!$E:$E&Table1!$F:$F,0),MATCH(A10,Table1!$6:$6,0)), "")
as per my comment:
Find the rows outside the loop as they will all be the same, then just find the column in the loop. It will cut down on the number of calc.
Dim LastRowColumnA As Long
Dim i As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Sheet1
LastRowColumnA = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Dim gRow As Variant
gRow = .Evaluate("MATCH($G$9&$E$4,Table1!$E1:$E27&Table1!$F1:$F27,0)")
Dim hRow As Variant
hRow = .Evaluate("MATCH($H$9&$E$4,Table1!$E1:$E27&Table1!$F1:$F27,0)")
Dim iRow As Variant
iRow = .Evaluate("MATCH($I$9&$E$4,Table1!$E1:$E27&Table1!$F1:$F27,0)")
Dim jRow As Variant
jRow = .Evaluate("MATCH($J$9&$E$4,Table1!$E1:$E27&Table1!$F1:$F27,0)")
For i = 11 To LastRowColumnA
If Sheet1.Cells(i, 1).Value <> "" And Not IsError(gRow) And Not IsError(hRow) And Not IsError(iRow) And Not IsError(jRow) Then
Dim clm As Variant
clm = Application.Match(.Range("A" & i), Worksheets("Table1").Range("6:6"), 0)
If Not IsError(clm) Then
.Cells(i, 7) = Worksheets("Table1").Cells(gRow, clm)
.Cells(i, 8) = Worksheets("Table1").Cells(hRow, clm)
.Cells(i, 9) = Worksheets("Table1").Cells(iRow, clm)
.Cells(i, 10) = Worksheets("Table1").Cells(jRow, clm)
End If
End If
Next
End With
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
If that is still too slow then one will need to use variant arrays and skip looping the ranges as this is slow.
I have code that runs and does what I want it to do with the click of the command button, however when executing, it runs very slow. The code grabs data from one sheet and inserts/formats it into another sheet in two separate tables that have been converted into range. I did this because I need to automatically update two different graphs with certain data. I'm still new with VBA coding and any kind of direction or help to make the code run faster is appreciated, whether that be tips or ways to get rid of unnecessary code since it is probably longer than it needs to be.
Public Sub Button1_Click() ' Update Button
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Dim lastRowPart As Long
Dim lastRowCW As Long
Dim lastRowQty As Long
Dim lastRowQtyLeft As Long
Dim lastRowDescrip As Long
Dim i, j, k As Integer
Dim IO As Worksheet: Set IO = Sheets("Inventory Overview")
Dim TD As Worksheet: Set TD = Sheets("Trend Data")
'1. Copies and formats data
lastRowPart = IO.Cells(Rows.count, "F").End(xlUp).Row
lastRowDescrip = IO.Cells(Rows.count, "G").End(xlUp).Row
lastRowQtyLeft = IO.Cells(Rows.count, "O").End(xlUp).Row
lastRowQty = IO.Cells(Rows.count, "I").End(xlUp).Row
lastRowCW = IO.Cells(Rows.count, "L").End(xlUp).Row
TD.Cells.UnMerge ' reset***
j = 2
k = 2
For i = 2 To lastRowCW
If IO.Cells(i, "L").Value = "Unknown" Then
TD.Cells(j, "G").Value = IO.Cells(i, "L").Value
TD.Cells(j, "H").Value = IO.Cells(i, "F").Value
TD.Cells(j, "I").Value = IO.Cells(i, "I").Value
TD.Cells(j, "J").Value = IO.Cells(i, "O").Value
TD.Cells(j, "K").Value = IO.Cells(i, "G").Value
j = j + 1
Else
TD.Cells(k, "A").Value = IO.Cells(i, "L").Value
TD.Cells(k, "B").Value = IO.Cells(i, "F").Value
TD.Cells(k, "C").Value = IO.Cells(i, "I").Value
TD.Cells(k, "D").Value = IO.Cells(i, "O").Value
TD.Cells(k, "E").Value = IO.Cells(i, "G").Value
k = k + 1
End If
Next
' Autofit
TD.range("B1:B" & lastRowPart).Columns.AutoFit
TD.range("E1:E" & lastRowDescrip).Columns.AutoFit
TD.range("H1:H" & lastRowPart).Columns.AutoFit
TD.range("K1:K" & lastRowDescrip).Columns.AutoFit
'2. Sort Cells
Dim LastRow As Long
LastRow = TD.Cells(Rows.count, 5).End(xlUp).Row
With TD.Sort ' sorts data from A to Z
.SetRange TD.range("A2:E" & LastRow)
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
'3. Merge CW Cells
' rngMerge = range for parts reworked/left with known CW
' URngMerge = range for parts reported with unknown CW
Dim rngMerge As range, URngMerge As range, cell As range, lastRowMerge As Long, ULastRowMerge As Long
lastRowMerge = TD.Cells(Rows.count, 1).End(xlUp).Row
ULastRowMerge = TD.Cells(Rows.count, 7).End(xlUp).Row
Set rngMerge = TD.range("A1:A" & lastRowMerge)
Set URngMerge = TD.range("G1:G" & ULastRowMerge)
MergeAgain:
For Each cell In rngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain
End If
Next
MergeAgain2:
For Each cell In URngMerge
If cell.Value = cell.Offset(1, 0).Value And IsEmpty(cell) = False Then
range(cell, cell.Offset(1, 0)).Merge
GoTo MergeAgain2
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
I've googled extensively, but can't seem to find anything on my problem. I have a workbook that has various VBA intermingled with in cell formulas. As it sits now it works fine, but if I try and add or modify a simple cell reference such as "=N24" it breaks my code and throws up the error:
Run-time error '-2147417848 (80010108)': Method 'Range' of object'_Worksheet' failed
This happens whether I'm referencing a calculated cell, a user filled cell, or a blank cell.
Here's the sheet calculate code, which is the only code on this particular sheet. I know it's rudimentary, but usually simple is good. When it throws this error, it breaks at:
Sheets("CALCULATIONS").Range("N24").ClearContents
If I remove that code, then it breaks at the first IF statement line.
Private Sub Worksheet_Calculate()
Dim SIZE As String
Dim THICKNESS As Single
Dim WIDTH As Single
Dim HEIGHT As Single
Dim WALL As Single
Dim WALL1 As String
Dim OD As Single
Dim FINALROW As Integer
Dim i As Integer
Sheets("CALCULATIONS").Range("N24").ClearContents
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "STRUCTURAL_I_BEAM" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("IBEAM").Range("Q2:Q100").ClearContents
SIZE = Sheets("SHEET1").Range("F4").Value
FINALROW = Sheets("IBEAM").Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("IBEAM").Cells(i, 2) = SIZE Then
Worksheets("IBEAM").Cells(i, 8).Copy
Sheets("IBEAM").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("IBEAM").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "STRUCTURAL_CHANNEL" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("CHANNEL").Range("Q2:Q100").ClearContents
SIZE = Sheets("SHEET1").Range("F4").Value
FINALROW = Sheets("CHANNEL").Cells(Rows.Count, 2).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("CHANNEL").Cells(i, 2) = SIZE Then
Worksheets("CHANNEL").Cells(i, 6).Copy
Sheets("CHANNEL").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("CHANNEL").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "STRUCTURAL_ANGLE" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("ANGLE").Range("Q2:Q100").ClearContents
WIDTH = Sheets("SHEET1").Range("F4").Value
HEIGHT = Sheets("SHEET1").Range("G4").Value
THICKNESS = Sheets("SHEET1").Range("H4").Value
FINALROW = Sheets("ANGLE").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("ANGLE").Cells(i, 3) = WIDTH And Worksheets("ANGLE").Cells(i, 4) = HEIGHT And Worksheets("ANGLE").Cells(i, 6) = THICKNESS Then
Worksheets("ANGLE").Cells(i, 7).Copy
Sheets("ANGLE").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("ANGLE").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "TUBE_RECTANGLE" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("RECTTUBE").Range("Q2:Q100").ClearContents
WIDTH = Sheets("SHEET1").Range("F4").Value
HEIGHT = Sheets("SHEET1").Range("G4").Value
WALL = Sheets("SHEET1").Range("H4").Value
FINALROW = Sheets("RECTTUBE").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("RECTTUBE").Cells(i, 3) = WIDTH And Worksheets("RECTTUBE").Cells(i, 4) = HEIGHT And Worksheets("RECTTUBE").Cells(i, 5) = WALL Then
Worksheets("RECTTUBE").Cells(i, 6).Copy
Sheets("RECTTUBE").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("RECTTUBE").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "TUBE_SQUARE" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("SQUARETUBE").Range("Q2:Q100").ClearContents
WIDTH = Sheets("SHEET1").Range("F4").Value
WALL = Sheets("SHEET1").Range("H4").Value
FINALROW = Sheets("SQUARETUBE").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("SQUARETUBE").Cells(i, 3) = WIDTH And Worksheets("SQUARETUBE").Cells(i, 5) = WALL Then
Worksheets("SQUARETUBE").Cells(i, 6).Copy
Sheets("SQUARETUBE").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("SQUARETUBE").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "TUBE_ROUND" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("ROUNDTUBE").Range("Q2:Q100").ClearContents
OD = Sheets("SHEET1").Range("F4").Value
WALL1 = Sheets("SHEET1").Range("H4").Value
FINALROW = Sheets("ROUNDTUBE").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("ROUNDTUBE").Cells(i, 3) = OD And Worksheets("ROUNDTUBE").Cells(i, 4) = WALL1 Then
Worksheets("ROUNDTUBE").Cells(i, 5).Copy
Sheets("ROUNDTUBE").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("ROUNDTUBE").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "PIPE" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("PIPE").Range("Q2:Q100").ClearContents
OD = Sheets("SHEET1").Range("F4").Value
WALL1 = Sheets("SHEET1").Range("H4").Value
FINALROW = Sheets("PIPE").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("PIPE").Cells(i, 3) = OD And Worksheets("PIPE").Cells(i, 4) = WALL1 Then
Worksheets("PIPE").Cells(i, 5).Copy
Sheets("PIPE").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("PIPE").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "SOLID_ROUND" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("ROUND").Range("Q2:Q100").ClearContents
OD = Sheets("SHEET1").Range("F4").Value
FINALROW = Sheets("ROUND").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("ROUND").Cells(i, 3) = OD Then
Worksheets("ROUND").Cells(i, 4).Copy
Sheets("ROUND").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("ROUND").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "SOLID_FLAT" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("FLAT").Range("Q2:Q100").ClearContents
THICKNESS = Sheets("SHEET1").Range("F4").Value
WIDTH = Sheets("SHEET1").Range("G4").Value
FINALROW = Sheets("FLAT").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("FLAT").Cells(i, 3) = THICKNESS And Worksheets("FLAT").Cells(i, 4) = WIDTH Then
Worksheets("FLAT").Cells(i, 5).Copy
Sheets("FLAT").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("FLAT").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "SOLID_SQUARE" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("SQUARE").Range("Q2:Q100").ClearContents
WIDTH = Sheets("SHEET1").Range("F4").Value
FINALROW = Sheets("SQUARE").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("SQUARE").Cells(i, 3) = WIDTH Then
Worksheets("SQUARE").Cells(i, 4).Copy
Sheets("SQUARE").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("SQUARE").Range("Q2").Value
Application.ScreenUpdating = True
End If
If ThisWorkbook.Sheets("SHEET1").Range("E4") = "SOLID_HEX" And ThisWorkbook.Sheets("SHEET1").Range("F4") <> 0 Then
Application.ScreenUpdating = False
Sheets("HEX").Range("Q2:Q100").ClearContents
WIDTH = Sheets("SHEET1").Range("F4").Value
FINALROW = Sheets("HEX").Cells(Rows.Count, 3).End(xlUp).Row
For i = 2 To FINALROW
If Worksheets("HEX").Cells(i, 3) = WIDTH Then
Worksheets("HEX").Cells(i, 4).Copy
Sheets("HEX").Range("Q" & Rows.Count).End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
End If
Next i
Worksheets("CALCULATIONS").Range("N24").Value = Worksheets("HEX").Range("Q2").Value
Worksheets("CALCULATIONS").Range("N25").Value = Worksheets("CALCULATIONS").Range("N8").Value / 12 * Worksheets("CALCULATIONS").Range("N24").Value
Worksheets("CALCULATIONS").Range("N26").Value = Worksheets("CALCULATIONS").Range("N25").Value - ((Worksheets("CALCULATIONS").Range("N6").Value * Worksheets("CALCULATIONS").Range("N10").Value / 12) * Worksheets("CALCULATIONS").Range("N24").Value)
Application.ScreenUpdating = True
End If
End Sub
While Excel is Busy calculating the cells, you are trying to delete/change the cell, invoking another calculation event. Hence blocking the cell/range access. Same will happen you had a mix of chart sheets with normal sheets.
Just disable the events before making any change/delete and once done re-enable events.
...............
Dim i As Integer
Application.EnableEvents = False
Sheets("CALCULATIONS").Range("N24").ClearContents
.........Your Code....
.....................
Application.ScreenUpdating = True
End If
Application.EnableEvents = True
Another alternative is to wait till CalculationState is xlDone but if you too many lengthy calculation, this might crash your application.
Of course you can not put reference on Range("N24") because you will get an infinite loop.
The first line of your code is proof for that:
Sheets("CALCULATIONS").Range("N24").ClearContents
Why, because you put reference of Range("N24") and click ENTER you get fired Change event, than your line for ClearContents erase content and after that you got calculation in your cell with this reference and here we go again fired Change Event because of that. And so on and so on (an infinite loop).
At your place I tried to do the following.
For example edit this line of code:
Sheets("CALCULATIONS").Range("N24").ClearContents
with this
If Sheets("CALCULATIONS").Range("N24") <> "" Then
Sheets("CALCULATIONS").Range("N24").ClearContents
End If
End every part of code with ClearContents edit like above example.
This would ensure the non-appearance of infinite loop.
I have code that will insert the number of rows based on data missing between 2 numbers but I am unable to figure out the code to get it to copy and paste the years I am missing.
Thanks in advance for any help, I am pretty good at manipulating existing code but I can't find any code to add to this to make it work
Here is the code I have to insert the right number of blank rows
Public Sub Insert()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
lastRow = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Cells(lastRow, 1).Select
Set CurrentCell = ActiveSheet.Cells(lastRow, 1)
For n = lastRow To 0 Step -1
If n = lastRow Then GoTo CheckLastRow
If n = 1 Then GoTo CheckfirstRow
ActiveCell.Offset(-2, 0).Select
CheckLastRow:
Set NextCell = CurrentCell.Offset(-1, 0)
ActiveCell.Offset(1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Set CurrentCell = NextCell
Next n
'To be performed on the firstrow in the column
CheckfirstRow:
ActiveCell.Offset(-1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
My data looks like this
Column A is number of Rows I need Column B&C has years
B = 2009
C = 2013
It would need the output to copy the line and look like
2009 2010
2010 2011
2011 2012
2012 2013
I added this to the code and I still only have blank lines
Public Sub InsertTest()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'pre XL97 xlManual
lastRow = ActiveSheet.UsedRange.Rows.Count
ActiveSheet.Cells(lastRow, 1).Select
Set CurrentCell = ActiveSheet.Cells(lastRow, 1)
For n = lastRow To 0 Step -1
If n = lastRow Then GoTo CheckLastRow
If n = 1 Then GoTo CheckfirstRow
ActiveCell.Offset(-2, 0).Select
CheckLastRow:
Set NextCell = CurrentCell.Offset(-1, 0)
ActiveCell.Offset(1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
With Worksheets("Sheet1")
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
For j = 0 To YearDifference - 1
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End With
Set CurrentCell = NextCell
Next n
'To be performed on the firstrow in the column
CheckfirstRow:
ActiveCell.Offset(-1, 0).Select
For i = 1 To CurrentCell
ActiveCell.EntireRow.Insert
Next i
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
TESTED
First off, you should always avoid using Select and ActiveCell as described here.
Try adding the following loop before your Set CurrentCell = NextCell line:
With Worksheets("Sheet1")
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
For j = 0 To YearDifference - 1
.Cells(n + j, 1).Value = .Cells(n, 1).Value
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End With
You'll need to change the sheet reference as necessary and you should dimension the variables at the beginning of your code.
EDIT
Replace your code with this and it should work:
Sub InsertTest()
Dim LastRow As Long
Dim newYear As Long
Dim YearDifference As Long
Dim n As Long, j As Long
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
With Worksheets("Sheet1")
LastRow = .Cells(Rows.Count, 2).End(xlUp).Row
For n = LastRow To 1 Step -1
If n Mod 10 = 0 Then DoEvents
If .Cells(n, 1).Value <> "" Then
newYear = .Cells(n, 2).Value
YearDifference = .Cells(n, 3).Value - newYear
If YearDifference > 1 Then
Application.StatusBar = "Updating Row #" & n
.Range(.Cells(n + 1, 1), .Cells(n + YearDifference - 1, 15)).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
For j = 0 To YearDifference - 1
.Rows(n + j).Value = .Rows(n).Value
.Cells(n + j, 2).Value = newYear
newYear = newYear + 1
.Cells(n + j, 3).Value = newYear
Next j
End If
End If
Next n
End With
Application.StatusBar = False
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
EDIT 2 - The code now includes a DoEvents line that runs every 10 iterations. This frees up some resources so that the code will run in the background. For a sheet with 27,000 rows like yours, it may take a couple hours to run the code, but you should be able to do other things in the meantime. I've also added a line to update the status bar so you can see which row the code is on.