I'm trying to locate a macro that would do the following:
1) Go through Column C to locate identical values.
2) If there are identical values in column C and the values in column A are different, put both of those values into column A.
The coding below appears to be close to what I'd like. Such as, deleting the duplicate rows and combining the cells. However, it is not combining the correct cells.
So for example, on rows 65 & 66 I'd like for there to be only 1 row for "CLAIM_NO" 525533564 with "2325 / 2337" in cell A
Sub test()
Dim i As Long
For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
If Cells(i, "C") = Cells(i - 1, "C") Then
Cells(i - 1, "A") = Cells(i - 1, "A") & " / " & Cells(i - 1, "A")
Rows(i).Delete
End If
One tiny problem in the original code:
Sub test()
Dim i As Long
For i = Cells(Rows.Count, "C").End(xlUp).Row To 2 Step -1
If Cells(i, "C") = Cells(i - 1, "C") Then
Cells(i - 1, "A") = Cells(i - 1, "A") & " / " & Cells(i, "A")
Rows(i).Delete
End If
Next i
End Sub
Related
Sample data: Click to get image
I need to delete duplicate values in the column for Distance, that is column I. There are empty rows between each group.
I want to keep just the topmost value present in each group. Note that the column may have similar values in different groups that shouldn't be deleted.
Here is what I tried. But it deletes useful values if the value is the same between different groups(as code would but that's not what I want).
Dim colJ As Range
Set colJ = ActiveSheet.UsedRange.Columns("J")
For i = 2 To lr
If .Cells(i, 11) = .Cells(i - 1, 11) Then
.Cells(i, 11) = ""
End If
If .Cells(i, 11) = .Cells(i + 2, 11) Then
.Cells(i + 2, 11) = ""
End If
If .Cells(i, 11) = .Cells(i + 3, 11) Then
.Cells(i + 3, 11) = ""
End If
If .Cells(i, 11) = .Cells(i + 4, 11) Then
.Cells(i + 4, 11) = ""
End If
If .Cells(i, 11) = .Cells(i + 5, 11) Then
.Cells(i + 4, 11) = ""
End If
Next i
Please, try the next code:
Sub DeleteGroupDuplicates()
Dim sh As Worksheet, lastRow As Long, rng As Range, A As Range
Set sh = ActiveSheet 'use here the necessary sheet
lastRow = sh.Range("I" & sh.rows.Count).End(xlUp).row 'last row of "I:I"
'create a discontinuous range, in order to create areas between empty rows:
Set rng = sh.Range("I2:I" & lastRow).SpecialCells(xlCellTypeConstants)
For Each A In rng.Areas 'iterate between all areas (intervals between empty rows)
A.UnMerge
A.RemoveDuplicates Columns:=1, Header:=xlNo 'remove duplicates, no header...
Next
End Sub
I have a sheet with multiple columns and in column A there is data where I have removed the duplicates.
This is the code to insert nine blank lines below each of the unique values.
Sub RowAdder()
Dim i As Long, col As Long, lastRow As Long
col = 1 lastRow = Cells(Rows.Count, col).End(xlUp).Row
For i = lastRow To 3 Step -1
If Cells(i - 1, col) <> Cells(i, col) Then
Range(Cells(i, col).EntireRow, Cells(i + 8, col).EntireRow).Insert shift:=xlDown
End If
Next I
End Sub
I need to adapt this code to copy the values of each unique value to the blank lines below for column A to C.
On the last line I need the value to be copied down into 9 blank rows.
maybe you'ar after something like this
Sub RowAdder()
Dim i As Long, col As Long
col = 1
With Range(Cells(2, col), Cells(Rows.Count, col).End(xlUp))
For i = .Rows(.Rows.Count).Row To 3 Step -1
If Cells(i - 1, col) <> Cells(i, col) Then Range(Cells(i, col).EntireRow, Cells(i + 8, col).EntireRow).Insert shift:=xlDown
Next i
With .Resize(.Rows.Count + 9)
With .SpecialCells(xlCellTypeBlanks)
.FormulaR1C1 = "=R[-1]C"
Intersect(.EntireRow, Range("B:C")).FormulaR1C1 = "=RC[-1]"
End With
With Intersect(.EntireRow, Range("A:C"))
.Value = .Value
End With
End With
End With
End Sub
I have a data set that consists of columns A-D. Values in A and D are the same respectively, as are B and C. It is listed for the purposes of A correlating to B, and C to D. What I would like to do is to be able to create a new two column list using the combinations of A&B and C&D. But I need them to go in the order they are originally listed i.e. new sheet, Row 1 A&B, Row 2 C&D, Row 3 A&B etc.
At first I tried simple filters and sorting, but due to the range of the data set at times, it makes the values that need to be close too each other too far. I tried a few failed splices and cuts. I had hoped there would just be a built in excel function.
Option Explicit
Sub combineList()
Dim i As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow
If Cells(i, 1) = "" Then
'do nothing
Else
If Cells(i, 9) = "" Then
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
Cells(i + 1, 9) = Cells(i, 4)
Cells(i + 1, 10) = Cells(i, 5)
Else
i = i + 1
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
Cells(i + 1, 9) = Cells(i, 4)
Cells(i + 1, 10) = Cells(i, 5)
'i = i - 1
End If
End If
Next i
End With
End Sub
First attempt, trying to get it to skip over rows for C&D.
Sub newMethod()
Dim i As Long
Dim j As Long
Dim lRow As Long
Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("a" & .Rows.Count).End(xlUp).Row
For i = 2 To lRow Step -1
If Cells(i, 1) = "" Then
'do nothing
Else
Cells(i, 9) = Cells(i, 1)
Cells(i, 10) = Cells(i, 2)
'i = i + 1
End If
Next i
For j = 2 To lRow Step 2
If Cells(j, 1) = "" Then
'do nothing
Else
Cells(j + 1, 9) = Cells(j, 4)
Cells(j + 1, 10) = Cells(j, 5)
'j = j + 1
End If
Next j
End With
End Sub
As stated above, to be able to reorganize the list by "shuffling" it together. Basically each row split into two. My attempts have ended with loops that just constantly overwrite themselves.
You can obtain your desired results using formulas.
It is a matter of deriving the mathematics of obtaining the correct row/col numbers in sequence.
F2: =INDEX($A:$D,FLOOR(ROWS($1:2)/2,1)+1,MOD(ROWS($1:2),2)*2+1)
G2: =INDEX($A:$D,FLOOR(ROWS($1:2)/2,1)+1,MOD(ROWS($1:2),2)*2+2)
*** Edit 7/19
#AcsErno The formula to sum works fine, but since there's 8 rows, it enters the sum in each blank row. Is there a way to enter more than 1 formula into the code?
I've tried to copy the formula (Cells(LastRow + 2, j).FormulaLocal...) and change the +1 to +2 (and so forth), but only the first blank row sums the range desired, the other ones either sum/equal to the row above it.
Updated Excel
'sum inbetween blanks
finalRow = Cells(Worksheets("page1").Rows.Count, 1).End(xlUp).Row
For Each j In Array(12, 13, 14) 'original: For j = 1 To finalCol
For i = finalRow + 1 To 1 Step -1
If IsEmpty(Cells(i, j)) Then
If IsEmpty(Cells(i - 2, j)) Then
firstrow = i - 1
LastRow = firstrow
Else
LastRow = i - 1
firstrow = Cells(i - 1, j).End(xlUp).Row
End If
Cells(LastRow + 1, j).FormulaLocal = _
"= sum(" & Range(Cells(firstrow, j), Cells(LastRow, j)).Address(False, False) & ")"
Cells(LastRow + 2, j).FormulaLocal = _
"= sum(" & Range(Cells(firstrow, j), Cells(LastRow, j)).Address(False, False) & ")"
End If
Next i
Next j
Application.ScreenUpdating = True
If it helps, here are some of the formulas I'll be using:
=SUMIF(P138:P158,"<>*Hold*",L138:L158)
=SUM(SUMIF(H5:H21,{"China"},L5:L21))
=SUM(SUMIF(H5:H21,{"Other"},L5:L21))
=SUM(SUMIF(O12:O28,{"*H1*"},L12:L28))
=SUM(SUMIF(O12:O28,{"H2","H2-PRESSED"},L12:L28))
Link to Sum Code
Link to Enter Blank Rows
My data is separated with 8 blank rows for each different week number with 8 blank rows. I need to insert formulas that sum specific things within each week/between the blanks.
The amount of rows will be dynamic, so the formulas need to be too. The only code I used to sum only works well if it has 1 blank row in between, (not 8), and I'm not sure how to add more rows/formulas with it.
Here is what the excel looks like (shortened version)
Here is what I'm trying to make it look like
'insert blank columns based on change in wk
Dim X As Long, LastRow As Long
Const DataCol As String = "A"
Const StartRow = 2
LastRow = Cells(Rows.Count, DataCol).End(xlUp).Row
For X = LastRow To StartRow + 1 Step -1
If Cells(X, DataCol).Value <> Cells(X - 1, DataCol) Then Rows(X).Resize(8).Insert
Next
finalRow = Cells(Worksheets("page1").Rows.Count, 1).End(xlUp).Row
finalCol = Cells(1, Worksheets("page1").Columns.Count).End(xlToLeft).Column
For j = 12 To 14 'original: For j = 1 To finalCol
For i = finalRow + 1 To 1 Step -1
If IsEmpty(Cells(i, j)) Then
If IsEmpty(Cells(i - 2, j)) Then
firstrow = i - 1
LastRow = firstrow
Else
LastRow = i - 1
firstrow = Cells(i - 1, j).End(xlUp).Row
End If
Cells(i, j) = Application.WorksheetFunction.Sum(Range(Cells(firstrow, j), Cells(LastRow, j)))
End If
Next i
Next j
It is not clear why you are changing firstrow in every loop. Also, why are you overwriting original values in the column. If you have a static table and want to summarize a column underneath, simply identify the first and the last row (as you correctly do), and
Cells(LastRow + 1, j) = Application.WorksheetFunction.Sum(Range(Cells(firstrow, j), Cells(LastRow, j)))
or you can insert a formula
Cells(LastRow + 1, j).FormulaLocal = _
"=sum(" & Range(Cells(firstrow, j), Cells(LastRow, j)).Address(False, False) & ")"
You can also consider SUMIF to add H1 and H2 categories only.
It is also not clear why you are summarizing string columns. It makes no sense. You know exactly where the numeric columns are so you can specify the column numbers. I suggest option 1:
For j = 6 To 8
or option 2:
For Each j in Array (6,7,8) ' it is more flexible
I have a spreadsheet that has about 19 columns and the amount of rows are always changing. Column A contains "Item IDs", column N contains "# of Items Sold", and column O contains "# of Items". I am trying to create a macro that inserts a row every time the "Item ID" in column A changes, and totals up the "# of Items Sold" as well as the "# of Items". I would also like to copy the "Item ID" into this new row if possible. If anybody could help me with this I would be VERY appreciative.
UPDATE: See below for screenshots of the spreadsheet example (I tried to post images but since I'm new I guess I don't have this level of access yet).
How the spreadsheet looks now:
How I would like the spreadsheet to look after running the macro:
The best option for you would be Data ► Subtotal. It's the least time consuming.
Before:
1. Subtotal is in Outline group:
2. Details:
After:
ZygD, I appreciate your help. I really was looking for a macro as this is just one of probably 7 or so macro's that are going to be tied into a one button solution for somebody else who doesn't have the time/knowledge to subtotal these rows.
I came up with a macro that copied the spreadsheet to a temp sheet. In that temp sheet it adds a gray row every time the ID changes, and subtotals the 2 aforementioned columns... while copying all the other info down. However, this caused Excel to freeze up for a while... so instead I had it delete all columns except the ones I needed, subtotal, & delete all rows except the one's that are gray (subtotaled). Here's the macro I came up with (in case anybody else is looking for something similar):
Sub SubTotal()
Dim i As Long
Dim numberOfRows As Long
Dim j
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
'Copies SellerTotals to SellerTotals(Temp)
Sheets("SellerTotals").Select
Sheets("SellerTotals").Copy Before:=Sheets("Pacing")
Sheets("SellerTotals (2)").Select
Sheets("SellerTotals (2)").Name = "SellerTotals(Temp)"
Worksheets("SellerTotals(Temp)").Activate
Range("B:M,P:T").Select
Selection.Delete Shift:=xlToLeft
' number of IDs
numberOfRows = Cells(Rows.Count, "A").End(xlUp).Row
' do bottom row first
Cells(numberOfRows + 1, 1).Value = Cells(numberOfRows, 1).Value
Cells(numberOfRows + 1, 2).FormulaR1C1 = "=SUMIF(R[-" & numberOfRows - 1 & "]C[-1]:R[-" & numberOfRows - (numberOfRows - 1) & "]C[-1],""" & Cells(numberOfRows, 1).Value & """,R[-" & numberOfRows - 1 & "]C[0]:R[-" & numberOfRows - (numberOfRows - 1) & "]C[0])"
Cells(numberOfRows + 1, 3).FormulaR1C1 = "=SUMIF(R[-" & numberOfRows - 1 & "]C[-2]:R[-" & numberOfRows - (numberOfRows - 1) & "]C[-2],""" & Cells(numberOfRows, 1).Value & """,R[-" & numberOfRows - 1 & "]C[0]:R[-" & numberOfRows - (numberOfRows - 1) & "]C[0])"
' convert to value
Cells(numberOfRows + 1, 2).Value = Cells(numberOfRows + 1, 2).Value
Cells(numberOfRows + 1, 3).Value = Cells(numberOfRows + 1, 3).Value
Range(Cells(numberOfRows + 1, 1), Cells(numberOfRows + 1, 3)).Interior.Color = RGB(192, 192, 192)
' insert blank row in between each group of IDs
' loop backwards because we are inserting rows
For i = numberOfRows To 3 Step -1
If Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
Cells(i, 1).EntireRow.Insert xlShiftDown
' copy ID name down
Cells(i, 1).Value = Cells(i - 1, 1).Value
' put formula into Total & Total Cap field
Cells(i, 2).FormulaR1C1 = "=SUMIF(R[-" & i - 1 & "]C[-1]:R[-" & i - (i - 1) & "]C[-1],""" & Cells(i, 1).Value & """,R[-" & i - 1 & "]C[0]:R[-" & i - (i - 1) & "]C[0])"
Cells(i, 3).FormulaR1C1 = "=SUMIF(R[-" & i - 1 & "]C[-2]:R[-" & i - (i - 1) & "]C[-2],""" & Cells(i, 1).Value & """,R[-" & i - 1 & "]C[0]:R[-" & i - (i - 1) & "]C[0])"
' convert to value
Cells(i, 2).Value = Cells(i, 2).Value
Cells(i, 3).Value = Cells(i, 3).Value
Range(Cells(i, 1), Cells(i, 3)).Interior.Color = RGB(192, 192, 192)
End If
Next i
' Delete Blank Rows
For j = Range("A1").End(xlDown).Row To 2 Step -1
If Cells(j, 1).Interior.Color <> RGB(192, 192, 192) Then Cells(j, 1).EntireRow.Delete
Next j
End Sub