insert entire same row beneath when condition was met - vba

I am working on the below code to insert same entire row below/beneath original one. I had a hard time fulfilling the requirement because I am just new to making macros.
I already tried searching but not able to code correctly. It is working to insert an empty row. But what I need is to insert the row that met the condition. Below is the screenshot/code for my macro.
Private Sub CommandButton1_Click()
Dim rFound As Range, c As Range
Dim myVals
Dim i As Long
myVals = Array("LB") '<- starts with 51, VE etc
Application.ScreenUpdating = False
With Range("F1", Range("F" & Rows.Count).End(xlUp))
For i = 0 To UBound(myVals)
.AutoFilter field:=1, Criteria1:=myVals(i)
On Error Resume Next
Set rFound = .Offset(2).Resize(.Rows.Count - 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
.AutoFilter
If Not rFound Is Nothing Then
For Each c In rFound
Rows(c.Row + 1).Insert
c.Offset(1, -1).Value = ActiveCell.Value
Next c
End If
Next i
End With
Application.ScreenUpdating = True
End Sub

Sub Test()
Dim rng As Range
Dim rngData As Range
Dim rngArea As Range
Dim rngFiltered As Range
Dim cell As Range
Set rng = Range("A1").CurrentRegion
'Exclude header
With rng
Set rngData = .Offset(1).Resize(.Rows.Count - 1)
End With
rng.AutoFilter Field:=6, Criteria1:="LB"
Set rngFiltered = rngData.Columns("F:F").SpecialCells(xlCellTypeVisible)
rng.AutoFilter Field:=6
For Each rngArea In rngFiltered.Areas
For Each cell In rngArea
'// When inserting a row,
'// iteration variable "cell" is adjusted accordingly.
Rows(cell.Row + 1).Insert
Rows(cell.Row).Copy Rows(cell.Row + 1)
Next
Next
End Sub

Below is the code I just used . Thank you!
Private Sub CommandButton2_Click()
Dim x As Long
For x = ActiveSheet.UsedRange.Rows.CountLarge To 1 Step -1
If Cells(x, "F") = "LB" Then
Cells(x, "F") = "ComP"
Cells(x + 1, "F").EntireRow.Insert
Cells(x, "F").EntireRow.Copy Cells(x + 1, "F").EntireRow
End if
Next x
End Sub

Related

Check range of Columns in each row and delete row if all columns have no values in them

I want to create a macro that goes through each row in my sheet and checks columns F:I if they have values in them.
If ALL columns are empty then the current row should be deleted.
I tried recycling some code but when I run it, all rows in that sheet get deleted for some reason.
This is the code I have so far:
Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
Dim noValues As Range, MyRange As Range
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)
On Error Resume Next
Set noValues = Intersect(ActiveCell.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0
If noValues Is Nothing Then
Rows(RowToTest).EntireRow.Delete
End If
Next RowToTest
End Sub
You can do this way (it is more efficient to delete rows all in one go using Union):
Option Explicit
Public Sub DeleteRows()
Dim unionRng As Range, rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1") '<== Change to your sheet name
For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)) '<== Column C cells to loop over from row 2 to last row
If Application.WorksheetFunction.CountBlank(rng.Offset(, 3).Resize(1, 4)) = 4 Then 'rng.Offset(, 3).Resize(1, 4)) limits to column F:I. CountBlank function will return number of blanks. If 4 then all F:I columns in that row are blank
If Not unionRng Is Nothing Then
Set unionRng = Union(rng, unionRng) 'gather qualifying ranges into union range object
Else
Set unionRng = rng
End If
End If
Next rng
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete '<== Delete union range object if contains items
Application.ScreenUpdating = True
End Sub
Or this way:
Option Explicit
Public Sub DeleteRows()
Dim unionRng As Range, rng As Range
Application.ScreenUpdating = False
With ThisWorkbook.Worksheets("Sheet1")
For Each rng In .Range(.Cells(2, 3), .Cells(.Rows.Count, "C").End(xlUp)).Offset(, 3).Resize(.Cells(.Rows.Count, "C").End(xlUp).Row - 1, 4).Rows
On Error GoTo NextLine
If rng.SpecialCells(xlCellTypeBlanks).Count = 4 Then
If Not unionRng Is Nothing Then
Set unionRng = Union(rng, unionRng)
Else
Set unionRng = rng
End If
End If
NextLine:
Next rng
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub
Try using WorksheetFunction.CountA.
Option Explicit
Sub DeleteRowBasedOnCriteria()
Dim RowToTest As Long
Dim MyRange As Range
For RowToTest = Cells(Rows.Count, 3).End(xlUp).Row To 2 Step -1
Set MyRange = Range("F" & RowToTest & ":I" & RowToTest)
If WorksheetFunction.CountA(MyRange) = 0 Then
MyRange.EntireRow.Delete
End If
Next RowToTest
End Sub
Try the following:
On Error Resume Next
Set noValues = Intersect(myRange.EntireRow.SpecialCells(xlConstants), MyRange)
On Error GoTo 0
If noValues Is Nothing Then
Rows(RowToTest).EntireRow.Delete
Else
Set noValues = Nothing
End If

How to delete empty cells in excel using vba

This is just a sample I am testing the code in this data. I have three columns in sheet2. I have to delete the empty cells. This is the updated code which is working for column B only. You can check the snapshot
Sub delete()
Dim counter As Integer, i As Integer
counter = 0
For i = 1 To 10
If Cells(i, 1).Value <> "" Then
Cells(counter + 1, 2).Value = Cells(i, 1).Value
counter = counter + 1
End If
Next i
End Sub
Sample screenshot
If all you want is to delete the empty cells, give this a try...
Sub DeleteBlankCells()
Dim rng As Range
On Error Resume Next
Set rng = Intersect(ActiveSheet.UsedRange, Range("A:C"))
rng.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End Sub
Not the most elegant solution but it works.
Option Explicit
Sub delete()
Dim rCells As Range, rCell As Range, sFixCell As String
Set rCells = Range("A1:A13")
For Each rCell In rCells
If rCell = "" Then
sFixCell = rCell.Address
Do While rCell.Value = ""
rCell.delete Shift:=xlUp
Set rCell = Range(sFixCell)
Loop
End If
Next rCell
End Sub

Remove row if cell value not in list

I have 2 sheets : in the first i have date and in sheet2 i have a list of names in column A . I want to delete all the rows that don't have the names from sheet2 in the column O from the first sheet. The code just deletes everything from the first sheet. Any help is welcomed.
Sub Demo()
Dim Rng As Range, List As Object, Rw As Long
Dim x As Date
x = Now()
Set List = CreateObject("Scripting.Dictionary")
With Sheets("Sheet2")
For Each Rng In .Range("A1", .Range("A" & Rows.Count).End(xlUp))
If Not List.Exists(Rng.Value) Then
List.Add Rng.Value, Nothing
End If
Next
End With
With Sheets("query " & Format(x, "dd.mm.yyyy"))
For Rw = .Range("O" & Rows.Count).End(xlUp).Row To 1 Step -1
If Not List.Exists(.Cells(Rw, "O").Value) Then
.Rows(Rw).Delete
End If
Next
End With
Set List = Nothing
End Sub
I'm not sure if this does exactly what you wants, but it does something very similar. To be clear:
Marks the cell adjacent to the list of names in Sheet1, if the name is found, then subsequently deletes the entire row if the the cell in said adjacent column is empty.
Sub Macro()
Dim r As Long
Dim r2 As Long
Dim counter As Long
Dim counter2 As Long
Range("O1").Select
Selection.End(xlDown).Select
r = ActiveCell.Row
Sheets(ActiveSheet.Index + 1).Select
Range("A1").Select
Selection.End(xlDown).Select
r2 = ActiveCell.Row
Range("A1").Select
For counter = 1 To r2
needle = ActiveCell.Value
Sheets(ActiveSheet.Index - 1).Select
On Error GoTo NotFound
Range(Cells(1, 15), Cells(r, 15)).Find(needle).Select
Selection.Offset(0, 1).Value = "found"
NotFound:
Sheets(ActiveSheet.Index + 1).Select
Selection.Offset(1, 0).Select
Next
Sheets(ActiveSheet.Index - 1).Select
Range("P1").Select
For counter2 = 1 To r
If ActiveCell.Value = "" Then Selection.EntireRow.Delete
Selection.Offset(1, 0).Select
Next
Cleanup:
Range("P1:P10000").Value = ""
End Sub
It is however, rather ugly and inefficient code. Lmk if there's something that needs changing!
i would do it like this:
Dim i as integer
dim x as integer
Dim rngSearch as Range
Dim strName as String
Dim ws1 as Worksheet
dim ws2 as Worksheet
Set ws1 = Thisworkbook.worksheets(1)
Set ws2 = Thisworkbook.worksheets(2)
x = ws1.cells(ws1.rows.count,1).end(xlup).row
for i = 2 to x
strName = ws1.cells(i, 1)
set rngSearch = ws2.columns(15).find(strName)
if rngSeach is nothing then
ws1.rows(i).entirerow.delete
i = i-1
end if
next i
It's not tested but it should work like this.
Edit: I think you have to put the worksheets in right order. I think i mixed them up here.

VBA search in two ranges

I'm more than new at this, and I'm having trouble sorting out For...Next loops.
I want to track to two text variables in two columns, so that when both variables are found in a row text is added to that row in a different column.
This is what I have so far:
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Set Rng1 = Range("B1:B100")
Set Rng2 = Range("A1:A100")
For Each cel In Rng1
If InStr(1, cel.Value, "A") > 0 Then
For Each cel In Rng2
If InStr(1, cel.Value, "B") > 0 Then
cel.Offset(0, 5).Value = "AB"
End If
Next
End If
Next cel
End Sub
You might even be able to just do this?
Sub AB()
With ActiveSheet
For I = 1 To 100
If InStr(1, .Cells(I, 2), "A") > 0 And InStr(1, .Cells(I, 1), "B") > 0 Then
.Cells(I, 6).Value = "AB" 'i think offset 5 is column F?
End If
Next
End With
End Sub
Appreciate you have an answer now, but here's a different method using Find. Always good to know several ways to do something.
Sub AB()
Dim rng As Range
Dim itemaddress As String
With Columns(1)
Set rng = .Find("A", searchorder:=xlByRows, lookat:=xlWhole)
If Not rng Is Nothing Then
itemaddress = rng.Address
Do
If rng.Offset(0, 1) = "B" Then
rng.Offset(0, 2).Value = "AB"
End If
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And itemaddress <> rng.Address
End If
End With
End Sub
You're using `cel' to step through each loop - the inner loop will get confused.
Along the vein of #findwindow answer (appeared as I was typing this). Loop just once and when a match is found check the cell next to it.
Sub AB()
Dim Rng1 As Range
Dim Rng2 As Range
Dim cel1 As Range
'Be specific about which sheet your ranges are on.
With ThisWorkbook.Worksheets("Sheet1")
Set Rng1 = .Range("B1:B100")
Set Rng2 = .Range("A1:A100")
End With
For Each cel1 In Rng1
'Check each value in column B.
If InStr(1, cel1.Value, "A") > 0 Then
'If a match is found, check the value next to it.
If InStr(1, cel1.Offset(, -1), "B") > 0 Then
cel1.Offset(, 4).Value = "AB"
End If
End If
Next cel1
End Sub

Delete rows that not contain string in my array

Pls help me modify this code but I would like to keep it 90% the same.
I want to delete the rows that does not contain the array items. So my program deletes rows with a, b in cell. How can I modify the below code so that it erases the other a, b to remain in exec.
myArr = Array("a","b")
For I = LBound(myArr) To UBound(myArr)
'Sheet with the data, you can also use Sheets("MySheet")
With ActiveSheet
'Firstly, remove the AutoFilter
.AutoFilterMode = False
'Apply the filter
.Range("E1:E" & .Rows.Count).AutoFilter Field:=1, Criteria1:=myArr(I)
Set rng = Nothing
With .AutoFilter.Range
On Error Resume Next
Set rng = .Offset(1, 0).Resize(.Rows.Count - 1, 1) _
.SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If Not rng Is Nothing Then rng.EntireRow.Delete
End With
'Remove the AutoFilter
.AutoFilterMode = False
End With
Next I
This works for me... I have commented the code so you should not have a problem understanding it...
Option Explicit
Dim myArr
Sub Sample()
Dim ws As Worksheet
Dim Lrow As Long, i As Long
Dim rRange As Range, delRange As Range
myArr = Array("a", "b", "c")
Set ws = ThisWorkbook.Sheets("MySheet")
With ws
'~~> Get last row of Sheet
Lrow = .Range("A" & .Rows.Count).End(xlUp).Row
For i = 2 To Lrow
If Not DoesExists(.Range("A" & i).Value) Then
If delRange Is Nothing Then
Set delRange = .Range("A" & i)
Else
Set delRange = Union(delRange, .Range("A" & i))
End If
End If
Next i
If Not delRange Is Nothing Then delRange.EntireRow.Delete
End With
End Sub
Function DoesExists(clVal As Variant) As Boolean
Dim j As Long
For j = LBound(myArr) To UBound(myArr)
If clVal = myArr(j) Then
DoesExists = True: Exit For
End If
Next j
End Function