I have the following code block to take out various errors and assign an error code description to the data. It works fine as long as the filter returns a result. If it does not then it deletes the header row. How can I prevent that from happening? Thanks in advance.
Sheets("Tempsheet").Select
Range("A1:K1").AutoFilter
Range("A1:K1").AutoFilter Field:=5, Criteria1:="0", Criteria2:=0
Range("K2:K" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "Excluded: $0.00 Amount"
Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy
Sheets("Excluded").Select
Range("A2").PasteSpecial
Sheets("Tempsheet").Select
Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
Sheets("Tempsheet").AutoFilterMode = False
If no data is returned by the filter then Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row) will return row 1, so test for row > 1 before doing the Delete
If Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).Row > 1 then
... .Delete
End If
Something like this code which tests for a filter result should do it
Dim ws As Worksheet
Dim ws2 As Worksheet
Set ws = Sheets("Tempsheet")
Set ws2 = Sheets("Excluded")
Set rng1 = ws.Range(ws.[a1], ws.Cells(Rows.Count, "k").End(xlUp))
rng1.AutoFilter Field:=5, Criteria1:="0", Criteria2:=0
If rng1.SpecialCells(xlVisible).Rows.Count > 1 Then
ws.Range("K2:K" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "Excluded: $0.00 Amount"
ws.Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy
ws2.[a2].PasteSpecial Paste:=xlPasteValues
rng1.Offset(1, 0).Resize(rng1.SpecialCells(xlVisible).Rows.Count - 1).EntireRow.Delete
End If
Sheets("Tempsheet").AutoFilterMode = False
Sheets("Tempsheet").Select
Range("A1:K1").AutoFilter
Range("A1:K1").AutoFilter Field:=5, Criteria1:="0", Criteria2:=0
Range("K2:K" & Range("A" & Rows.Count).End(xlUp).Row).Formula = "Excluded: $0.00 Amount"
Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Copy
Sheets("Excluded").Select
Range("A2").PasteSpecial
Sheets("Tempsheet").Select
if Range("A" & Rows.Count).End(xlUp).Row > 1 then
Range("A2:K" & Range("A" & Rows.Count).End(xlUp).Row).EntireRow.Delete
end if
Sheets("Tempsheet").AutoFilterMode = False
Related
I currently have this code that works to insert full rows. However, I was hoping to limit the inserting of the row to columns A:J.
Bonus points to see who can help me figure out that if I delete column C why my current code doesn't work?
I tried to add .resize(1,10) but for some reason I keep getting errors, maybe the location in which I try to add this function. Any guidance/help is appreciated as always!
Here is my current code:
VBA Code:
Sub Add_Job()
Dim act As Worksheet
Set act = ThisWorkbook.ActiveSheet
bot_row = act.Range("Z1")
act.Rows(bot_row & ":" & bot_row + (5)).Insert Shift:=x1ShiftDown
act.Range("A3:J8").Copy
act.Range("A" & bot_row & ":J" & bot_row + (5)).PasteSpecial xlPasteFormats
act.Range("A" & bot_row & ":J" & bot_row + (5)).PasteSpecial xlPasteFormulas
Range("B" & bot_row & ":B" & bot_row + (5)).ClearContents
Application.CutCopyMode = False
End Sub
Edit: Updated Code that works now. However, I still don't understand if I delete column C, why it throws an error?
Dim act As Worksheet
Set act = ThisWorkbook.ActiveSheet
bot_row = act.Range("Z1")
act.Range("A" & bot_row & ":J" & bot_row + (5)).Insert Shift:=xlShiftDown
act.Range("A3:J8").Copy
act.Range("A" & bot_row & ":J" & bot_row + (5)).PasteSpecial xlPasteFormats
act.Range("A" & bot_row & ":J" & bot_row + (5)).PasteSpecial xlPasteFormulas
Range("B" & bot_row & ":B" & bot_row + (5)).ClearContents
Application.CutCopyMode = False
Writing macros to copy cells in a different workbook in a specific format.Getting error at different lines everytime I run the code
I tried with unhide cells, selection
For i = 1 To lastrow
If IsEmpty(ThisWorkbook.Sheets("Summary").Range("A" & i).Value) = False Then
If ThisWorkbook.Sheets("Summary").Range("A" & i).Font.Bold = True Then
'Range("A" & i).Copy Range("B" & i)
Set BoldTitle = ThisWorkbook.Sheets("Summary").Range("A" & i)
x = i
Else
ws.Range("A" & i).Value = "Winter I"
BoldTitle.Copy
ws.Range("B" & i).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Summary").Range("A" & i).Copy
ws.Range("C" & i).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Summary").Range("B" & i).Copy
ws.Range("D" & i).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Summary").Range("C" & i).Copy
ws.Range("E" & i).PasteSpecial xlPasteValues
ThisWorkbook.Sheets("Summary").Range("D" & i).Copy
ws.Range("F" & i).PasteSpecial xlPasteValues
End If
Else
End If
Next i
I have workbook namely "OPTIONS", having multiple sheets. Data is in sheets no. 4 to 31; in columns A, B, C and D in different multiple rows. All 4 to 31 sheets have different names. In all 4 to 31 sheets, in column C have two names called "CE" and "PE". I want find CE name and copy data from column D ( which is in front of CE ) and paste in sames respective sheets in column F. Same find CE name copy data from column B and paste in column G to their respective sheets. Again now find PE name copy data in from column D and copied data should paste in column H to their respective sheets. Again find PE name copy data from column B and paste in column I. Paste should start from row 2 i.e. below heading.
In conclusion, available data is from 4 to 31 sheets having different names, in column A B C and D. Find two names from column C from all sheets and paste data from D to F, from B to G, from D to H and from B to I; in their respective sheets.
Thanks in advance.
I have tried code for first three sheets and its working fine. But the code will go too long. Expecting short code. I am not understanding how should I post my example code here. Someone please help.
Sub watermasa()
Dim x As String, y As String
x = InputBox("Please Enter the first name")
y = InputBox("Please Enter the second name")
With Sheets("ADANIENT")
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, x
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIENT").Range("F" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIENT").Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, y
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIENT").Range("H" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIENT").Range("I" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
With Sheets("ADANIPORTS")
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, x
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIPORTS").Range("F" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIPORTS").Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, y
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIPORTS").Range("H" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ADANIPORTS").Range("I" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
With Sheets("APOLLOTYRE")
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, x
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("F" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, y
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("H" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("I" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
With Sheets("ARVIND")
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, x
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("ARVIND").Range("F" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("G" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & .Range("C" & Rows.Count).End(3).Row).AutoFilter 1, y
.Range("D2:D" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("H" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.Range("B2:B" & .Range("C" & Rows.Count).End(3).Row).SpecialCells(12).Copy
Sheets("APOLLOTYRE").Range("I" & Rows.Count).End(3)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
End Sub
You can loop through the worksheets by walking through an array of their worksheet names or by the ordinal index number of their current position in the worksheet queue.
Sub watermasa_by_Name()
Dim x As String, y As String, lrc As Long, v As Long, vWSs As Variant
x = InputBox("Please Enter the first name")
y = InputBox("Please Enter the second name")
vWSs = Array("ADANIENT", "ADANIPORTS", "APOLLOTYRE", "ARVIND")
For v = LBound(vWSs) To UBound(vWSs)
With Sheets(vWSs(v))
lrc = .Range("C" & Rows.Count).End(xlUp).Row
.Range("C1:C" & lrc).AutoFilter 1, x
.Range("D2:D" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("F" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.Range("B2:B" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("G" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & lrc).AutoFilter 1, y
.Range("D2:D" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("H" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.Range("B2:B" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("I" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
Next v
End Sub
Sub watermasa_by_Index()
Dim x As String, y As String, lrc As Long, w As Long
x = InputBox("Please Enter the first name")
y = InputBox("Please Enter the second name")
For w = 4 To 31 ' maybe For w = 4 To sheets.count ?
With Sheets(w)
lrc = .Range("C" & Rows.Count).End(xlUp).Row
.Range("C1:C" & lrc).AutoFilter 1, x
.Range("D2:D" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("F" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.Range("B2:B" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("G" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
.Range("C1:C" & lrc).AutoFilter 1, y
.Range("D2:D" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("H" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.Range("B2:B" & lrc).SpecialCells(xlCellTypeVisible).Copy
.Range("I" & Rows.Count).End(xlUp)(2).PasteSpecial xlPasteValues
.AutoFilterMode = False
End With
Next w
End Sub
I'm not sure why you used the With ... End With statement for the copy and not the paste operation but it does clean up your code a bit.
I have one worksheet called mainData, which contains all data for ten products.
When I enter new data in mainData, I want to automatically copy the new data into the last row of another product worksheet. When I enter new data into mainData, how can I recognize the new data belongs to which product's worksheet, hence copy the new data into the product worksheet?
I'm stuck in copying it to another worksheet because I need to copy it to another ten worksheets according to product's type.
Here's what I've done to the mainData:
With Sheets("mainData")
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("B" & LastRow) = ComboBox1.Text
.Range("C" & LastRow) = TextBox1.Text
.Range("D" & LastRow) = TextBox2.Text
.Range("E" & LastRow) = TextBox3.Text
.Range("F" & LastRow) = TextBox4.Text
.Range("G" & LastRow) = TextBox5.Text
.Range("H" & LastRow) = ComboBox2.Text
.Range("I" & LastRow) = TextBox6.Text
.Range("J" & LastRow) = TextBox7.Text
.Range("K" & LastRow) = TextBox8.Text
Range("B32:B320").Select
ActiveWorkbook.Worksheets("mainData").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("mainData").Sort.SortFields.Add Key:=Range("B32:B305") _
, SortOn:=xlSortOnValues, Order:=xlAscending, CustomOrder:= _
"prod1, prod2, prod3, prod4, prod5, prod6, prod7, prod8, prod9, prod10" _
, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("mainData").Sort
.SetRange Range("B32:W305")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
here's what i mean.when i enter new prod1 data into mainData worksheet, i want to automatically copy it into the last row of product 1 worksheet. i may enter many type of product i.e prod2,prod4 into mainData so how to copy this data into its particular product worksheet?
Is this what you are trying? (UNTESTED)
Also I have not done any error handling. I am sure you will take care of it :)
Dim prd As String
Dim ws As Worksheet
Dim LastRow As Long
'~~> Extract the number from the combobox
prd = Trim(Replace(ComboBox1.Text, "prod", ""))
'~~> Decide which sheet the data needs to be written to
'~~> Please ensure that sheets have names like "Product 1", "Product 2" etc
Set ws = ThisWorkbook.Sheets("Product " & prd)
'~~> Update it to the relevant sheet
With ws
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("B" & LastRow) = ComboBox1.Value
.Range("C" & LastRow) = TextBox1.Text
.Range("D" & LastRow) = TextBox2.Text
.Range("E" & LastRow) = TextBox3.Text
.Range("F" & LastRow) = TextBox4.Text
.Range("G" & LastRow) = TextBox5.Text
.Range("H" & LastRow) = ComboBox2.Value
.Range("I" & LastRow) = TextBox6.Text
.Range("J" & LastRow) = TextBox7.Text
.Range("K" & LastRow) = TextBox8.Text
'~~> Sort the data
With .Range("B2:W" & LastRow)
.Sort Key1:=ws.Range("B2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End With
'~~> Update it in mainData
With Sheets("mainData")
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("B" & LastRow) = ComboBox1.Value
.Range("C" & LastRow) = TextBox1.Text
.Range("D" & LastRow) = TextBox2.Text
.Range("E" & LastRow) = TextBox3.Text
.Range("F" & LastRow) = TextBox4.Text
.Range("G" & LastRow) = TextBox5.Text
.Range("H" & LastRow) = ComboBox2.Value
.Range("I" & LastRow) = TextBox6.Text
.Range("J" & LastRow) = TextBox7.Text
.Range("K" & LastRow) = TextBox8.Text
'~~> Sort the data
With .Range("B2:W" & LastRow)
.Sort Key1:=Sheets("mainData").Range("B2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
End With
End With
I do not really know how to explain this in a clear manner. Please see attached image
I have a table with 4 different columns, 2 are identical to each other (NAME and QTY). The goal is to compare the differences between the QTY, however, in order to do it. I must:
1. sort the data
2. match the data item by item
This is not a big deal with small table but with 10 thousand rows, it takes me a few days to do it.
Pleas help me, I appreciate.
My logic is:
1. Sorted the first two columns (NAME and QTY)
2. For each value of second two columns (NAME and QTY), check if it match with first two column. If true, the insert the value.
3. For values are not matched, insert to new rows with offset from the rows that are in first two columns but not in second two columns
Is this what you are trying?
Option Explicit
Sub Sample()
Dim ws As Worksheet
Dim lastRow As Long, i As Long, newRow As Long
Dim aCell As Range, SrchRange As Range
Set ws = Sheets("Sheet1")
With ws
.Columns("A:B").Copy .Columns("G:G")
.Columns("G:H").Sort Key1:=.Range("G2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
newRow = lastRow
Set SrchRange = .Range("G2:G" & lastRow)
lastRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("I1").Value = "NAME": .Range("J1").Value = "QTY"
For i = 2 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Set aCell = SrchRange.Find(What:=.Range("C" & i).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
.Range("I" & aCell.Row).Value = .Range("C" & i).Value
.Range("J" & aCell.Row).Value = .Range("D" & i).Value
Else
newRow = newRow + 1
.Range("I" & newRow).Value = .Range("C" & i).Value
.Range("J" & newRow).Value = .Range("D" & i).Value
End If
End If
Next
End With
End Sub
SNAPSHOT
Based on your above requirements, the logic totally changes and hence I am posting it as a different answer.
Also in your "This is Wonderful" snapshot above, there is a slight error. As per logic SAMPLE10 cannot come above SAMPLE11. It has to come after SAMPLE11.
See the below snapshot
And here is the code :)
Option Explicit
Sub sAMPLE()
Dim ws As Worksheet
Dim lastRow As Long, i As Long, newRow As Long, rw As Long
Dim aCell As Range, SrchRange As Range
Set ws = Sheets("Sheet1")
With ws
.Columns("A:B").Copy .Columns("G:G")
.Columns("G:H").Sort key1:=.Range("G2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
.Columns("H:H").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
For i = 2 To lastRow
.Range("H" & i).Value = GetLastNumbers(.Range("G" & i).Value)
If .Range("H" & i).Value <> 0 Then
.Range("G" & i).Value = Left(.Range("G" & i).Value, _
Len(.Range("G" & i).Value) - Len(.Range("H" & i).Value))
End If
Next i
.Columns("G:H").Sort key1:=.Range("H2"), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = 2 To lastRow
If .Range("H" & i).Value <> 0 Then _
.Range("G" & i).Value = .Range("G" & i).Value & .Range("H" & i).Value
Next i
.Columns("H:H").Delete
newRow = lastRow
Set SrchRange = .Range("G2:G" & lastRow)
lastRow = .Range("C" & Rows.Count).End(xlUp).Row
.Range("I1").Value = "NAME": .Range("J1").Value = "QTY"
For i = 2 To lastRow
If Len(Trim(.Range("C" & i).Value)) <> 0 Then
Set aCell = SrchRange.Find(What:=.Range("C" & i).Value, LookIn:=xlFormulas, _
LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
.Range("I" & aCell.Row).Value = .Range("C" & i).Value
.Range("J" & aCell.Row).Value = Application.Evaluate("=SUMPRODUCT((C2:C" & lastRow _
& "=" & """" & .Range("C" & i).Value & """" & ")*(D2:D" & lastRow & "))")
Else
newRow = newRow + 1
.Range("I" & newRow).Value = .Range("C" & i).Value
.Range("J" & newRow).Value = .Range("D" & i).Value
End If
End If
Next
lastRow = .Range("G" & Rows.Count).End(xlUp).Row
For i = lastRow To 2 Step -1
If .Range("G" & i).Value = .Range("G" & i - 1).Value Then
.Range("H" & i - 1).Value = .Range("H" & i).Value + .Range("H" & i - 1).Value
If Application.WorksheetFunction.CountA(.Range("I" & i & ":J" & i)) = 0 Then
.Range("G" & i & ":J" & i).Delete Shift:=xlUp
Else
.Range("G" & i & ":H" & i).Delete Shift:=xlUp
End If
End If
Next i
lastRow = .Range("I" & Rows.Count).End(xlUp).Row
newRow = .Range("G" & Rows.Count).End(xlUp).Row
If lastRow <= newRow Then Exit Sub
.Range("I" & newRow & ":J" & lastRow).Sort key1:=.Range("I" & newRow), Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
For i = lastRow To newRow Step -1
If .Range("I" & i).Value = .Range("I" & i - 1).Value Then
.Range("J" & i - 1).Value = .Range("J" & i).Value + .Range("J" & i - 1).Value
.Range("I" & i & ":J" & i).Delete Shift:=xlUp
End If
Next i
End With
End Sub
Function GetLastNumbers(strVal As String) As Long
Dim j As Long, strTemp As String
For j = Len(strVal) To 1 Step -1
If Not IsNumeric(Mid(strVal, j, 1)) Then Exit For
strTemp = Mid(strVal, j, 1) & strTemp
Next j
GetLastNumbers = Val(Trim(strTemp))
End Function