*** 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
Related
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 currently have a macro that inserts 3 rows when the value in Column E changes (Course Department). In the 3 rows I am trying to merge the middle row and add the department into this row. I can't work out how to get it to merge, any help would be appreciated.
With Range("e" & myHeader + 2, Range("e" & Rows.Count).End(xlUp)).Offset(, 1)
.Formula = _
"=if(and(r[-1]c[-1]<>"""",rc[-1]<>"""",r[-1]c[-1]<>rc[-1])," & _
"if(r[-1]c=1,""a"",1),"""")"
.Value = .Value
On Error Resume Next
For i = 1 To 3
.SpecialCells(2, 1).EntireRow.Insert
.SpecialCells(2, 2).EntireRow.Insert
Next
This is how it is currently:
This is what I would like to have:
When inserting or deleting rows, work from the bottom up. Some simple offsets and resizing should be sufficient to insert the three rows, merge the cells and transfer the values.
Option Explicit
Sub insertDept3()
Dim i As Long
With Worksheets("sheet10")
For i = .Cells(.Rows.Count, "E").End(xlUp).Row - 1 To 1 Step -1
If .Cells(i, "E").Value <> .Cells(i + 1, "E").Value Or i = 1 Then
.Cells(i + 1, "A").Resize(3, 5).Insert shift:=xlDown
.Cells(i + 2, "A").Resize(1, 5).Merge
.Cells(i + 2, "A") = .Cells(i + 4, "E").Value
End If
Next i
End With
End Sub
I will leave the cell alignment and font formatting to you.
The below code loop column E, import three lines when the value change, merger Column A to column E , import and format value in the middle line.
Try:
Option Explicit
Sub test()
Dim i As Long, Lastrow As Long
Dim Department As String, NextDepartment As String
With ThisWorkbook.Worksheets("Sheet1")
Lastrow = .Cells(.Rows.Count, "E").End(xlUp).Row
For i = Lastrow To 2 Step -1
Department = .Range("E" & i).Value
NextDepartment = .Range("E" & i).Offset(-1, 0).Value
If Department <> NextDepartment Then
.Rows(i).EntireRow.Resize(3).Insert
.Range("A" & i + 1 & ":E" & i + 1).Merge
With .Range("A" & i + 1)
.Value = Department
.Font.Bold = True
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlCenter
End With
End If
Next i
End With
Output:
I'm trying to copy a cell and the adjacent cell in a row and insert it as a new row with all the data to the right of this cell also copied over. My data looks like this after mining.
and im trying to get my data to look like this:
the image above is just one record but essentially its moving all the people and their corresponding position in the original row to a new row. In each row there are about 5 employees and their positions.
thanks
EDIT Attempted code for just 2 cols. 1 position. the idea was to create the empty rows and just copy the rest of the data with auto fill, then work from there
Sub TransposeInsertRows()
Dim rng As Range
Dim i As Long, j As Long, k As Long
Dim x As Long, y As Long
Set rng = Application.InputBox _
(Prompt:="Range Selection...", _
Title:="Enter the name col and pos col", Type:=8)
Application.ScreenUpdating = False
x = rng(1, 1).Column + 2
y = rng(1, rng.Columns.Count).Column
For i = rng(rng.Rows.Count, 1).Row To rng(1, 1).Row Step -1
If Cells(i, x) <> "" And Cells(i, x + 1) <> "" Then
k = Cells(i, x - 2).End(xlToRight).Column
If k > y Then k = y
For j = k To x + 1 Step -1
Cells(i + 1, 1).EntireRow.Insert
With Cells(i + 1, x - 2)
.Value = .Offset(-1, 0)
.Offset(0, 1) = .Offset(-1, 1)
.Offset(0, 2) = Cells(i, j)
End With
Cells(i, j).ClearContents
Next j
End If
Next i
Application.ScreenUpdating = True
End Sub
If there are always 5 people in each row then this should do it:
Sub foo()
LastRow = Sheet1.Cells(Sheet1.Rows.Count, "A").End(xlUp).Row
For i = 1 To LastRow 'loop through rows
For x = 1 To 10 Step 2 'loop through columns
LastRow2 = Sheet2.Cells(Sheet2.Rows.Count, "A").End(xlUp).Row + 1 'find the next free row on Sheet2
Sheet2.Cells(LastRow2, 1).Value = Sheet1.Cells(i, x).Value 'add Person Name to Sheet2
Sheet2.Cells(LastRow2, 2).Value = Sheet1.Cells(i, x + 1).Value 'add position to Sheet2
Sheet1.Range("K" & i & ":U" & i).Copy Destination:=Sheet2.Cells(LastRow2, 3) 'copy range from K to U to Sheet2
Next x
Next i
End Sub
I know how to insert rows for sequential missing values, but how can I do this for unique values that I store in a range? For example:
Range of all needed values New list with missing values
2 2
3 5
5 7
6 15
7
10
15
The code below adds rows in a sequence (i.e. if list is 2 3 5, it adds 4) so it's not what I need but I don't know how to make it loop through a range and take values only from it
Sub RowsInSequence()
Dim i As Long, j As Long
i = Cells(Rows.Count, "A").End(xlUp).Row
Application.ScreenUpdating = False
For j = i To 1 Step -1
If Cells(j + 1, 1) <> "" Then
If Cells(j + 1, 1).Value - Cells(j, 1).Value > 1 Then
x = Cells(j + 1, 1).Value - Cells(j, 1).Value
Rows(j + 1 & ":" & x + j - 1).Insert
End If
End If
Next j
With Range("A1:A" & Range("A" & Rows.Count).End(xlUp).Row)
.Formula = "=Row()"
.Value = .Value
End With
Application.ScreenUpdating = True
End Sub
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