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.
Related
I have some code that colours in a row of information and then stores the date and the user that coloured in said row of information on a log.
That is all well and good but I would like to somehow figure out how to reverse said process. Currently if you use the code again on the same selection the colour changes back to 'no fill' but unfortunately I'm not sure how to remove that same information that was sent to the log initially. Any ideas?
Sub CompleteLine()
Dim RCount As Integer
RCount = Selection.Columns.Count
If Selection.Interior.Color = 5296274 Then
Selection.Interior.ColorIndex = 0
Else
If RCount = 16384 And Selection.Interior.Color <> 5296274 Then
Selection.Interior.Color = 5296274
With Sheets("Log")
.Cells(1, 1).End(xlDown).Offset(1) = Format(Date, "dd/mm/yyyy")
.Cells(1, 2).End(xlDown).Offset(1) = Environ("Username")
End With
End If
End If
End Sub
Try this out. There is room for improvement, but it should work. It should at least get you started
Sub CompleteLine()
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
Dim RCount As Integer
Dim lastrow As Long
Dim checkC As Boolean
RCount = Selection.Columns.Count
With Selection
If .Interior.Color = 5296274 Then
.Interior.ColorIndex = 0
checkC = False
Else
If RCount = 16384 And .Interior.Color <> 5296274 Then .Interior.Color = 5296274
checkC = True
End If
End With
With Sheets("Log")
lastrow = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 1
If checkC = True Then
.Range("A" & lastrow & ":A" & lastrow) = Format(Date, "dd/mm/yyyy")
.Range("B" & lastrow & ":B" & lastrow) = Environ("Username")
Else
If checkC = False Then .Range("A" & lastrow & ":B" & lastrow - 1).ClearContents
End If
End With
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub
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 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 %.
I have the following input:
and would like the following output:
The intended operation is to search column A for duplicate values (column is already sorted). Each duplicate value in A should be merged into 1 cell. Also, merge the same rows in B (take the top value if different, but safe to assume they are the same). Do not touch C.
I'm doing this manually now and it is a huge pain. I am new to VBA but it seems like that would be simple way to speed this up. Any tips?
Sub MergeCells()
'set your data rows here
Dim Rows As Integer: Rows = 20
Dim First As Integer: First = 1
Dim Last As Integer: Last = 0
Dim Rng As Range
Application.DisplayAlerts = False
With ActiveSheet
For i = 1 To Rows + 1
If .Range("A" & i).Value <> .Range("A" & First).Value Then
If i - 1 > First Then
Last = i - 1
Set Rng = .Range("A" & First, "A" & Last)
Rng.MergeCells = True
Set Rng = .Range("B" & First, "B" & Last)
Rng.MergeCells = True
End If
First = i
Last = 0
End If
Next i
End With
Application.DisplayAlerts = True
End Sub
I've done this a few times...
Public Sub MergeDuplicates()
'disable alerts to avoid clicking OK every time it merges
Application.DisplayAlerts = False
'define the range
Dim r As Range
Set r = Sheets("Sheet1").Range("A1:B4")
'need a row counter
Dim i As Long
i = 1
'variables to store the value in A in a row and its upstairs neighbor
Dim this_A As String
Dim last_A As String
'step through the rows of the range
For Each rw In r.Rows
If i > 1 Then 'only compare if this is not the first row - nothing to look backwards at!
'get the values of A for this row and the one before
this_A = rw.Cells(1, 1).Value
last_A = rw.Cells(1, 1).Offset(-1, 0).Value
'compare this A to the one above; if they are the same, merge the cells in both columns
If this_A = last_A Then
'merge the cells in column A
Sheets("Sheet1").Range(r.Cells(i - 1, 1), r.Cells(i, 1)).Merge
'merge the cells in column B
Sheets("Sheet1").Range(r.Cells(i - 1, 2), r.Cells(i, 2)).Merge
End If
End If
i = i + 1 'increment the counter
Next rw
'enable alerts
Application.DisplayAlerts = True
End Sub
Try this, easily adaptible as the range can be modified without changing anything else.
Sub MergeRng
Dim Rng As Range, xCell As Range, WorkRng As Range
Dim xRows As Integer
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Set WorkRng = Activeworkbook.ActiveSheet.Range("A1:B4")
xRows = WorkRng.Rows.Count
For Each Rng In WorkRng.Columns
For i = 1 To xRows - 1
For j = i + 1 To xRows
If Rng.Cells(i, 1).Value <> Rng.Cells(j, 1).Value Then
Exit For
End If
Next
With WorkRng.Parent.Range(Rng.Cells(i, 1), Rng.Cells(j - 1, 1))
.Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
i = j - 1
Next
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
Source:
https://www.extendoffice.com/documents/excel/1138-excel-merge-same-value.html
You have indicated that column A was sorted; it seems to me that both column A and column B should be sorted with column A as the primary key and column B as the secondary key.
Option Explicit
Sub wqwerq()
Dim i As Long, d As Long
Application.DisplayAlerts = False
With Worksheets("sheet3")
With .Cells(1, "A").CurrentRegion
.Cells.Sort Key1:=.Columns(1), Order1:=xlAscending, _
Key2:=.Columns(2), Order2:=xlDescending, _
Orientation:=xlTopToBottom, Header:=xlNo
For i = .Rows.Count To 1 Step -1
If Not .Cells(i, "B").MergeCells Then
d = Application.CountIfs(.Columns(1), .Cells(i, "A"), .Columns(2), .Cells(i, "B"))
If CBool(d - 1) Then
With .Cells(i, "B")
.Resize(d, 1).Offset(1 - d, 0).Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
End If
If i = Application.Match(.Cells(i, "A"), .Columns(1), 0) Then
d = Application.CountIfs(.Columns(1), .Cells(i, "A"))
If CBool(d - 1) Then
With .Cells(i, "A")
.Resize(d, 1).Merge
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
End With
End If
End If
Next i
End With
End With
Application.DisplayAlerts = True
End Sub
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.