I found a macro at Insert copied row based on cell value.
The macro inserts a blank row above any row that has a value of "0" in column E.
Instead of the empty row appearing above, I need it to appear below.
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "E"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "0" Then
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
Edit the following line from:
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
to:
.Cells(R+1, Col).EntireRow.Insert Shift:=xlDown
Pertinent to you question, modify a single line in original code: instead of:
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
use this one:
.Cells(R, Col).EntireRow.Insert Shift:=xlUp
Rgds,
Related
I have a table with data populated.
My goal is to insert a new row when data is entered into column 'S'
When inserting the new row, copy the value in column 'D' from the row above and paste into the new column.
This is what I've got to so far... I can add the row, but I can't seem to copy the cell in column D to paste as value in the new row... Thank you!
Sub InsertBlankRowsBasedOnCellValue()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim Col2 As Variant
Dim StartRow As Long
Col = "S"
Col2 = "D"
StartRow = 3
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) <> "" Then
.Cells(R, Col2).Copy
Range("D" & R).PasteSpecial xlPasteValues
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlDown
Application.CutCopyMode = False
End If
Next R
End With
Application.ScreenUpdating = True
End Sub
I'm trying to merge cells in excel using VBA based on the column value. For instance, on row one, wherever the month is the same, merge those cells. I've tried the following code :
Sub Main()
Dim j As Long
For j = 1 To 13
If StrComp(Cells(1, j), Cells(1, j + 1), vbTextCompare) Then
Range(Cells(1, j), Cells(1, j + 1)).Merge
End If
Next j
End Sub
Here, I'm keeping the row fixed as the first row and iterating over the columns and checking if the next cell value is same as the current value. However, in the output it's merging incorrect cells. What am I missing here?
This is easier to understand.
Application.DisplayAlerts = False
With ThisWorkbook.Sheets("Sheet1")
For i = 13 To 2 Step -1 'Loop from the last cell, and stop at the second column
If .Cells(1, i).Value = .Cells(1, i).Offset(, -1).Value Then
.Range(.Cells(1, i), .Cells(1, i).Offset(, -1)).Merge
End If
Next i
End With
Application.DisplayAlerts = True
Should work like this …
Option Explicit
Public Sub MergeSameValuesInRow()
Const iRow As Long = 1 'the row number
Const FirstColumn As Long = 1 'first column with data in iRow
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets("Sheet1") 'define your worksheet
Dim LastColumn As Long 'find last used column in iRow
LastColumn = ws.Cells(iRow, ws.Columns.Count).End(xlToLeft).Column
Dim StartCell As Range 'remember the start cell (first occurence of a new value)
Set StartCell = ws.Cells(iRow, FirstColumn)
Dim iCol As Long
For iCol = FirstColumn + 1 To LastColumn + 1 'loop through columns in iRow
If ws.Cells(iRow, iCol).Value <> StartCell.Value Then 'if value changed …
Application.DisplayAlerts = False 'hide merging messages
ws.Range(StartCell, ws.Cells(iRow, iCol - 1)).Merge 'merge from start cell until one before value change
Application.DisplayAlerts = True
Set StartCell = ws.Cells(iRow, iCol) 'set start cell to the next value
End If
Next iCol
End Sub
It will change this …
into this …
I found the code below over here: Insert row below based on cell value excel macro
It works but, like the poster in the other message, I want the new row to be inserted below the existing row (here the row with a "2" in it), rather than above. I've tried changing Shift:=xlDown to xlUp but that has no effect. What am I missing something?
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "C"
StartRow = 1
BlankRows = 1
With ActiveSheet
For R = LastUsedRow() To StartRow + 1 Step -1
If .Cells(R, Col) = "2" Then
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
End If
Next R
End With
End Sub
To insert the row below R use R + 1. Is this what you are trying?
Dim R As Long, LastRow As Long
LastRow = LastUsedRow()
With ActiveSheet
For R = LastRow To 2 Step -1
If .Range("C" & R).Value = 2 Then _
.Range("C" & R + 1).EntireRow.Insert Shift:=xlDown
Next R
End With
all.
I found in a previous post, a solution that solved most of my problem. I just need some help expanding on it a little. The following macro was posted (and I have amended it for my application) to add a row after the text "CC Total" appeared. I need this macro to add a row after "CC Total" and the text "Sum Total". how can I add this second criteria to the command?
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "A"
StartRow = 1
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) = "CC Total" Then
.Cells(R + 1, Col).EntireRow.Insert Shift:=xlUp
End If
Next R
End With
Application.ScreenUpdating = True
The following line is key here:
If .Cells(R, Col) = "CC Total" Then
To add extra criteria, you can either do
If .Cells(R, Col) = "CC Total" Or .Cells(R, Col) = "SUM Total" Then
or, to make it more accessible for more criteria:
If .Cells(R, Col) = "CC Total" Then
....
ElseIf .Cells(R, Col) = "SUM Total" Then
....
etc
End if
I need to insert rows according to the condition that the cell in DQ column is non-blank then I have to insert a new row, and also paste the row data in the new row data.
The problem is that I am not able to insert a row above the matched column and also I don't know how to copy the text.
Following is the code that I have:
Sub Macro()
nr = Cells(Rows.Count, 5).End(xlDown).Row
For r = 4 To nr Step 1
If Not IsEmpty(Cells(r, 121).Value) Then
Rows(r + 1).Insert Shift:=xlDown
Rows(r + 1).Interior.ColorIndex = 16
End If
Next
End Sub
For this you will have to use a reverse loop. I quickly wrote this code and it is not tested. Let me know if you get any error.
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long, r As Long
'~~> Change this to the relevant sheet
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
'~~> Get the last row which has data in Col DQ
lRow = .Cells(.Rows.Count, 121).End(xlDown).Row
'~~> Reverse Loop
For r = lRow To 4 Step -1
If Not IsEmpty(.Cells(r, 121).Value) Then
.Rows(r + 1).Insert Shift:=xlDown
.Rows(r + 1).Interior.ColorIndex = 16
End If
Next
End With
End Sub
I actually found the answer in this forum itself. Pasting the code and the link. Thanks a lot people.
Insert copied row based on cell value
Sub BlankLine()
Dim Col As Variant
Dim BlankRows As Long
Dim LastRow As Long
Dim R As Long
Dim StartRow As Long
Col = "DQ"
StartRow = 3
BlankRows = 1
LastRow = Cells(Rows.Count, Col).End(xlUp).Row
Application.ScreenUpdating = False
With ActiveSheet
For R = LastRow To StartRow + 1 Step -1
If .Cells(R, Col) <> "" Then
.Cells(R, Col).EntireRow.Copy
.Cells(R, Col).EntireRow.Insert Shift:=xlDown
.Cells(R, Col).EntireRow.Interior.ColorIndex = 4
End If
Next R
End With
Application.ScreenUpdating = True
End Sub