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
Related
I was writing a program for deleting a row in a Selection with Empty Cell. I wrote the code and it worked well but it have a deficiency.
Code Is:
Dim i As Integer
Dim j As Integer
Dim Num As Integer
Num = Selection.Cells.Count
'MsgBox ("Num of Cells " & Num)
Selection.End(xlUp).Select
If (IsEmpty(ActiveCell)) Then
Selection.End(xlDown).Select
End If
For i = 1 To Num
If (IsEmpty(ActiveCell)) Then
ActiveCell.Offset(1, 0).Select
ActiveCell.Offset(-1, 0).EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
Num = Num - 1
On Error GoTo Last
Else
ActiveCell.Offset(1, 0).Select
End If
Next
Last:
Exit
Now I was trying to rewrite the code with looping the cell in Range instead of above For loop:
Dim i As Integer
Dim j As Integer
Dim Num As Integer
Dim myRange As Range
ActiveSheet.Select
Set myRange = Selection.Cells
For Each myRange In Selection
If (IsEmpty(myRange)) Then
ActiveCell.EntireRow.Delete
On Error GoTo Last
Else
'ActiveCell.Offset(1, 0).Select
End If
Next myRange
Last:
Exit
This piece of code is not working Properly. Kindly put your Suggestions and rectify the Code
you could try
If WorksheetFunction.CountBlank(Selection) > 0 Then Intersect(Selection.SpecialCells(xlCellTypeBlanks).EntireRow, Selection.Columns(1)).EntireRow.Delete
Speciealcells seems to be easy to use.
Sub test()
Dim rngDB As Range
Set rngDB = Selection
On Error Resume Next
Set rngDB = rngDB.SpecialCells(xlCellTypeBlanks)
If Err.Number = 0 Then
rngDB.EntireRow.Delete
End If
End Sub
Here is an option that avoids relying on Selection and Select.
You can use a InputBox to determine the range. This will allow you to properly qualify all of your ranges/worksheets. You can then loop through the selected range and determine if the rows should be deleted (if blank).
At the end, delete all the rows at once. On larger operations, this will be much faster since you will only have 1 instance of deletion rather continuously deleting rows in the loop.
Option Explicit
Sub Blanks()
Dim MyRange As Range, MyCell As Range, DeleteMe As Range
Set MyRange = Application.InputBox("Select Range", Type:=8)
For Each MyCell In MyRange
If MyCell = "" Then
If DeleteMe Is Nothing Then
Set DeleteMe = MyCell
Else
Set DeleteMe = Union(DeleteMe, MyCell)
End If
End If
Next MyCell
If Not DeleteMe Is Nothing Then DeleteMe.EntireRow.Delete
End Sub
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
So I am trying to write a For Each loop to look through an entire row. If it finds the word "Specialty" Copy it over to the next three cells.
It does this part fine, but then when it loops around, of course the next cell has "Specialty" in it bc it just copied it over. I need to figure out how to say, if you've found "Specialty" and copied it over, jump 4 cells over and begin searching again..... Tried Offsetting the active cell but didn't work.
Any ideas?
Thanks!
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For Each Cell In rngRow
If InStr(1, Cell.Value, "Specialty") Then
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
End If
Next Cell
End Sub
Here's how to loop backwards given your current code:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Dim cIndex As Long
Set rngRow = Range("A8:BA8")
For cIndex = rngRow.Columns.Count To rngRow.Column Step -1
Set Cell = Cells(rngRow.Row, cIndex)
If InStr(1, Cell.Value, "Specialty", vbTextCompare) Then
Cell.Offset(, 1).Resize(, 3).Value = Cell.Value
End If
Next cIndex
End Sub
You could replace 'For each' by a an integer iterable:
Sub CopySpecialtyOver()
Dim i As Integer
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For i = 1 To rngRow.Cells.Count
Set Cell = rngRow(1, i)
If InStr(1, Cell.Value, "Specialty") Then
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
i = i + 3
End If
Next i
End Sub
Thank you so much! I ended up solving it like this:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Set rngRow = Range("A8:BA8")
For Each Cell In rngRow
If InStr(1, Cell.Value, "Specialty") Then
If InStr(1, Cell.Offset(0, -1).Value, "Specialty") Then
Else
Cell.Offset(0, 1).Value = Cell.Value
Cell.Offset(0, 2).Value = Cell.Value
Cell.Offset(0, 3).Value = Cell.Value
End If
End If
Next Cell
End Sub
For Each - as pointed out by other responses - may not be the best strategy. Nevertheless - as you asked for it - here comes a piece of code using some in-loop control to overcome the deficites of For Each in this use case:
Sub CopySpecialtyOver()
Dim rngRow As Range
Dim Cell As Range
Dim Found As Boolean
Dim Cnt As Integer
Set rngRow = Range("A8:BA8")
Found = False
Cnt = 0
For Each Cell In rngRow.Cells
If InStr(1, Cell.Value, "Specialty") And Not Found Then
' capture start of sequence - otherwise do nothing
Found = True
Cnt = 0
Else
If Found Then
'if in Found mode increment counter
Cnt = Cnt + 1
' expand using negative offset
If Cnt <= 3 Then
Cell = Cell.Offset(0, -Cnt).Value
End If
' break after 3rd
If Cnt = 3 Then
Found = False
Cnt = 0
End If
End If
End If
Next Cell
End Sub
This seemingly more complex code will have its advantage when run vertically (instead horizontally) over much more than just a handfull of cells, as For/Each performs much better than regular For/Next
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
I need this VBA to instead of just putting the value "X" in cells to grab the text from a cell within the work book. The cell is B4 within the Sheet "Order Entry". Thanks.
Sub Check()
Dim dat As Variant
Dim rng As Range
Dim i As Long
Set rng = Sheets("Customer List").Range("D2:D100")
dat = rng.Value
For i = LBound(dat, 1) To UBound(dat, 1)
If dat(i, 1) <> "" Then
rng(i, -2).Value = "X"
End If
Next
End Sub
Sub Check()
Dim dat As Variant
Dim rng As Range
Dim i As Long
Set rng = Sheets("Customer List").Range("D2:D100")
dat = rng.Value
For i = LBound(dat, 1) To UBound(dat, 1)
If dat(i, 1) <> "" Then
rng(i, -2).Value = ThisWorkBook.Sheets("Order Entry").Range("B4").Value
End If
Next
End Sub