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
Related
Im looking for a solution to get the result as in the screenshot. If theres at least 3 blanks or more then change second cell from first blank on first column to "x" :
Sub findThreeEmptyCells()
Dim lastRow As Long, i As Long
Dim firstEmptyCell As Range
lastRow = Cells(Rows.Count, 5).End(xlUp).Row
For i = 10 To lastRow
If Cells(i + 1, 5).Value = "" And Cells(i + 2, 5).Value = "" Then
Set firstEmptyCell = Cells(i + 2, 1)
Exit For
End If
Next i
If firstEmptyCell Is Nothing Then
MsgBox ("There are no two empty cells in a row")
Exit Sub
End If
firstEmptyCell.Value = "x"
End Sub
Sub findThreeEmptyCells()
Dim lastRow As Long, i As Long
Dim firstEmptyCell As Range
lastRow = Cells(Rows.Count, 5).End(xlUp).Row ' Assuming your column A has the most data or is the row you want to check.
For i = 10 To lastRow
If Cells(i + 1, 5).Value = "" And Cells(i + 2, 5).Value = "" And Cells(i + 3, 5).Value = "" Then
Set firstEmptyCell = Cells(i + 2, 1)
Exit For
End If
Next i
If firstEmptyCell Is Nothing Then
MsgBox ("There are no two empty cells in a row")
Exit Sub
End If
firstEmptyCell.Value = "x"
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 have VBA code which increments dates in the active cell to the next available column.
Dim lngLastCol As Long, lngRow As Long
lngRow = ActiveCell.Row
lngLastCol = Cells(lngRow, Columns.Count).End(xlToLeft).Column
If IsDate(Cells(lngRow, lngLastCol)) Then
With Cells(lngRow, lngLastCol + 1)
.Value = DateAdd("M", 1, CDate(Cells(lngRow, lngLastCol)))
.NumberFormat = Cells(lngRow, lngLastCol).NumberFormat
End With
End If
Instead of incrementing the month (and year) on the active row I am currently clicked on, I want to update the months in certain fixed rows i.e. Row 3, 17 and 42 (all in the same column).
Another approach, loop one column to the last row (in this case 250). In the second If formula you set which rows to add new columns to. So if this statement is true Cells(i, 2).Row = 3 (current row we loop is 3) then add a new column.
Therefore we replace the active row with a loop:
lngRow = ActiveCell.Row -> lngRow = Cells(i, 2).Row
The For i loop will from row 3 to row 250.
Sub ColumnsAdd()
Dim lngLastCol As Long, lngRow As Long, i As Long
For i = 3 To 250 'Loop from row 3 to 250
If Cells(i, 2).Row = 3 Or Cells(i, 2).Row = 17 Or Cells(i, 2).Row = 42 Then 'If any of the rows is 3, 17 or 42 then go and add new column
lngRow = Cells(i, 2).Row
lngLastCol = Cells(lngRow, Columns.Count).End(xlToLeft).Column
If IsDate(Cells(lngRow, lngLastCol)) Then
With Cells(lngRow, lngLastCol + 1)
.Value = DateAdd("M", 1, CDate(Cells(lngRow, lngLastCol)))
.NumberFormat = Cells(lngRow, lngLastCol).NumberFormat
End With
End If
End If
Next i
End Sub
I dont understand exactly what to you want but you can use the below code and if you want more adjustment let me know.
Option Explicit
Sub test()
Dim lngLastCol As Long, lngRow As Long
lngRow = ActiveCell.Row
lngLastCol = Cells(lngRow, Columns.Count).End(xlToLeft).Column
If IsDate(Cells(lngRow, lngLastCol)) Then
With Union(Cells(3, lngLastCol + 1), Cells(17, lngLastCol + 1), Cells(42, lngLastCol + 1))
.Value = DateAdd("M", 1, CDate(Cells(lngRow, lngLastCol)))
.NumberFormat = Cells(lngRow, lngLastCol).NumberFormat
End With
End If
End Sub
I have data in excel sheet, with headings in 1st Row, I want to trim them as shown below
For example
CT_CD_FILTER_AMT*_Integer
Change to
CT_CD_FILTER_AMT
Each column heading is different..and number of columns also different from each file
So I want select the value of each column and trim it until it reaches the blank cell in ( row1 only)
Pls help with code.
TIA.
Sub mac1()
Dim LastCol As Integer
Sheets("MySheet").Select
LastCol = Cells(1, 1).End(xlToRight).Column
For Each C In Range(Cells(1, 1), Cells(1, LastCol))
C.Value = Left(C.Value, InStr(C.Value, "") - 1)
Next C
End Sub
Or
Sub mac2()
Dim Col As Integer
Col = 1
Do While Cells(1, Col).Value <> ""
Cells(1, Col).Value = Left(Cells(1, Col).Value, InStr(Cells(1, Col).Value, "") - 1)
Col = Col + 1
Loop
End Sub
This is the statement I am currently using. I need to find a way to populate the two rows I've inserted, using the value of the last populated cell before my new empty rows. How do I do this?
Sub Insert_Rows()
Dim r As Long, mcol As String, i As Long, s As Long, ncol As Long
' find last used cell in Column A
r = Cells(Rows.Count, "A").End(xlUp).Row
' get value of last used cell in column A
mcol = Cells(r, 1).Value
'find last used cell in Column B
s = Cells(Rows.Count, "B").End(xlUp).Row
' get value of last used cell in Column B
ncol = Cells(s, 1).Value
' insert rows by looping from bottom
For i = r To 2 Step -1
If Cells(i, 1).Value <> mcol Then
mcol = Cells(i, 1).Value
Rows(i + 1).Insert
Rows(i + 1).Insert
End If
Next i
End Sub
After you have inserted the rows you can use:
Rows(i + 1).Cells(1, 1).Value = "hi.." 'or
Rows(i + 1).Cells(1, 1).Value = mcol
Rows(i + 2).Cells(1, 1).Value = "there"
to insert values into the first cells of these rows.