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
Related
please help i want to sort the name column such that each name starts after every blank cell.
I want it look something like this..pls help it's a pretty long column
Option Explicit
Sub SetNamePosition()
Dim arr As Variant
Dim i As Long: i = 1 ' for Loop
Dim j As Long: j = 1 ' for Array
Dim lastRow As Long: lastRow = Cells(Rows.Count, 1).End(xlUp).Row
Dim rngColB As Range: Set rngColB = Range("B2:B" & lastRow)
Dim rngNames As Range: Set rngNames = Range("C1") ' Temporary range
' Get column B names only
rngColB.SpecialCells(xlCellTypeConstants, 2).Copy
rngNames.PasteSpecial (xlPasteValues)
Application.CutCopyMode = False
Set rngNames = Range(rngNames, rngNames.End(xlDown))
' Load rngNames to array
arr = Application.Transpose(rngNames)
' Clear rng of column B and rngNames
rngColB.Clear
rngNames.Clear
' Insert names
For i = 2 To lastRow
' set name
Cells(i, 1).Offset(0, 1).Value = arr(j)
' find next cell
i = Cells(i, 1).End(xlDown).Row + 1
j = j + 1
Next i
End Sub
I's probably better to remove the empty ranges before making the array, but here's one way to distribute the names:
Loading the range ito an array, then go through the numbers and look for empty ranges.
This assumes that we are working with column "A" and "B" (1 and 2), starting at the top.
Sub test()
Dim arr As Variant
Dim lastRow As Long, i As Long, j As Long
lastRow = Cells(Rows.Count, "A").End(xlUp).Row
arr = Application.Transpose(Range("B2:B" & lastRow))
Range("B2:B" & lastRow).Clear
j = 1
For i = 2 To lastRow
Cells(i, 2) = arr(j)
j = j + 1
If j >= UBound(arr) Then Exit For
While arr(j) = "" And j < UBound(arr)
j = j + 1
Wend
While Not Cells(i, 1).Value = ""
i = i + 1
Wend
Next i
End Sub
Any leftover names will be removed
I have created below code which works like IF Col"B" any cell <> "" And Col"L" any cell = "Leop" then add row below to the active cell.
I mean I'm trying to achieve is to insert single row after certain row which contain in column B any value, and if column L in same row contains value = "Leop". Then add the row after that certain row.
But an error is appear. Compile Error: Invalid use of property on xlDown
Your help will be appreciated to fix it.
From this:
to this:
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long
Dim rng As Range
Dim rng2 As Range
Dim i As Long
Dim p As Long
Dim dat As Variant
Dim datt As Variant
Dim IRow As Long
Set ws = Thisworkbooks.Sheets("Sheet2")
With ws
LRow = .Range("A" & .Rows.Count).End(xlUp).Row
Set rng = .Range("B2:B" & LRow)
Set rng2 = .Range("L2:L" & LRow)
dat = rng
datt = rng2
IRow = Selection.Row
For i = LBound(dat, 1) To UBound(dat, 1)
For p = LBound(datt, 1) To UBound(datt, 1)
If dat(i, 1) <> "" And datt(p, 1) = "Leop" Then
Rows(IRow + 1).Select
Selection.Insert Shift: xlDown
End If
End Sub
It will be like in formula:
IF(AND(B2<>"",L2="Leop"),"InsertRowBelow to Row 2 If condition is met","")
and will drag it down to the lastRow.
Thisworkbooks.Sheets("Sheet2") should be Thisworkbook.Sheets("Sheet2") and missing = in Selection.Insert Shift:= xlDown
Inserting or deleting rows will change the last row number so start at the bottom and work upwards.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet, LRow As Long, r As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet2")
With ws
LRow = .Range("B" & .Rows.Count).End(xlUp).Row
For r = LRow To 2 Step -1
If .Cells(r, "B") <> "" And .Cells(r, "L") = "Leop" Then
.Rows(r + 1).Insert shift:=xlDown
n = n + 1
End If
Next
End With
MsgBox n & " rows inserted", vbInformation
End Sub
Try this with autofilter, you dont have to loop through each row. So it will work faster for larger data.
Option Explicit
Sub firstcondition()
Dim ws As Worksheet
Dim LRow As Long, cl As Range
Set ws = ThisWorkbook.Sheets("Sheet2")
LRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
ws.Range("L1:L" & LRow).AutoFilter 1, "Leop"
For Each cl In ws.Range("_FilterDatabase").SpecialCells(12).Cells
If ws.Range("B" & cl.Row) <> "" Then
cl.Offset(1).EntireRow.Insert Shift:=xlDown
End If
Next
ws.AutoFilterMode = False
End Sub
I need some help with comparing values from one column to another and delating it.
so far I have this:
Sub DelateDuplicates()
delArray = Sheets("Save").Range("B1:B") ' saved values
toDelate = Sheets("Validation").Range("B2:B").Value ' values to be checked and delated
lastRow = toDelate.Range("B1000").End(xlUp).Row ' last row
Firstrow = toDelate.Range("B2").End(xlDown).Row ' First row
Dim i As Long
For Lrow = lastRow To Firstrow Step -1
With Worksheets("Validation").Cells(Lrow, "A")
For i = 0 To UBound(delArray) ' arrays are indexed from zero
If Not IsError(.Value) Then
If .Value = delArray(i) Then
.EntireRow.Delete
Exit For
End If
End If
Next
End With
Next Lrow
End Sub
And I do have an error.
"1004 "Application-defined or Object-defined error" "
I have spent 2 days trying to figure it out so far no luck.
Any help will be appreciated.
I modified your code little bit. You can define your first rows and last row the want you want, I have kept it simple for the sake of concept
Option Explicit
Sub DelateDuplicates()
Dim Lrow As Long
Dim delarray()
With Worksheets("Save")
delarray = .Range("B1:B" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
End With
Dim i As Long
Dim lastrow As Long
Dim firstrow As Long
firstrow = 1
With Worksheets("Validation")
lastrow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Lrow = lastrow To firstrow Step -1
For i = 1 To UBound(delarray)
If Not IsError(.Cells(Lrow, "A").Value) Then
If .Cells(Lrow, "A").Value = delarray(i, 1) Then
.Cells(Lrow, "A").EntireRow.Delete
Exit For
End If
End If
Next i
Next Lrow
End With
End Sub
You can avoid loops within loops by using a Dictionary Object
Option Explicit
Sub DeleteDuplicates()
Dim wsSave As Worksheet, wsValid As Worksheet
Dim iLastRow As Long, iFirstRow As Long, i As Long, n As Long
Dim dict As Object, key, cell As Range
With ThisWorkbook
Set wsSave = .Sheets("Save")
Set wsValid = Sheets("Validation")
End With
Set dict = CreateObject("Scripting.Dictionary")
' get values to delete from Column B
For Each cell In wsSave.Range("B1", wsSave.Cells(Rows.Count, "B").End(xlUp))
key = Trim(cell)
If Len(key) > 0 Then
dict(key) = cell.Row
End If
Next
' scan Validation sheet and delete matching from Save
With wsValid
iFirstRow = .Cells(2, "B").End(xlDown).Row
iLastRow = .Cells(Rows.Count, "B").End(xlUp).Row
For i = iLastRow To iFirstRow Step -1
key = .Cells(i, "A")
If dict.exists(key) Then
.Rows(i).Delete
n = n + 1
End If
Next
End With
' resutl
MsgBox n & " rows deleted between row " & _
iFirstRow & " and " & iLastRow, vbInformation
End Sub
Here the code:
Sub deleterow2()
Dim a As Integer
Dim n As Integer
Dim c As Integer
LastRow = Range("F" & Rows.Count).End(xlUp).Row
For n = 0 To LastRow
a = 1
c = 0
Do Until c = 1
Cells(n + a, 6).Select
If Selection.value = Cells(n, 6) And Selection.value > 30 Then
Selection.EntireRow.Delete
Else
c = 1
End If
a = a + 1
Loop
Next n
End Sub
What s wrong with that?
Please see below corrected code... instead of starting n at 0, start with a at 0. Plus, avoid using .Select everything... and you should try to declare your ranges fully:
Sub deleterow222()
Dim lastRow As Long, R As Long
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet
Dim idColumn as Long: idColumn = 6
Dim diffColumn as Long: diffColumn = 19
lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
For R = lastRow To 2 Step -1
With ws
If .Cells(R, idColumn) = .Cells(R - 1, idColumn) And .Cells(R, diffColumn) > 30 Then
.Cells(R, idColumn).EntireRow.Delete
End If
End With
Next R
End Sub
Some Tips:
You could not use n = 0 because you will create an error. Rows start from 1.
When you loop in order to delete you start from the end.
For n = LastRow To 1 Step -1
If there are a lot of lines and you will use For Loop declare you variable As Long.
If you have a lot of rows it s better to use an Array.
Try to avoid .Select by creating a With Statement with the sheet name
With ThisWorkbook.Worksheets("Sheet1") and refer to cell using .Cells(n + A, 6).Value
Do Until should start also from high to low due to the fact that you go from bottom to top.
enter image description here
Sub deleterow2()
Dim lastRow As Long, R As Long
Dim ws As Worksheet: Set ws = ActiveWorkbook.ActiveSheet
lastRow = ws.Range("F" & ws.Rows.Count).End(xlUp).Row
For R = lastRow To 2 Step -1
With ws
If .Cells(R, 6).value = .Cells(R - 1, 6) And .Cells(R, 19).value > 30 Then
.Cells(R, 6).EntireRow.Delete
End If
End With
Next R
End Sub
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