Sub FillEmptyCell()
Dim rng As Range
Dim i As Long
Dim cell As Range
Dim sht As Worksheet
Set sht = ActiveWorkbook.Sheets("Sheet1")
sht.Activate
Set rng = Range(Range("C12"), Range("AD" & sht.UsedRange.Rows.Count))
For Each cell In rng
If cell.Value = "" Then
cell.Value = "0"
End If
Next
End Sub
I am trying to fill my blank spaces in sheet with zero dynamically.However,
I don't want this to fill zeroes in row that have no data. can someone help please?
See how this works,
Sub ZeroStuff()
Dim LstRw As Long, rng As Range, sh As Worksheet, c As Range
Set sh = Sheets("Sheet1")
With sh
LstRw = .Cells(.Rows.Count, "C").End(xlUp).Row + 1
Set rng = .Range("C12:C" & LstRw).SpecialCells(xlCellTypeBlanks)
For Each c In rng.Cells
.Range(c.Offset(, 1), c.Offset(, 27)) = 0
Next c
End With
End Sub
Related
I have two sheets. "Sales" and "Marketing". I want to enact the macro on the sheet "Sales". I keep getting error 9 on line 4.
Sub halveandcolorchange()
Dim Sa As Worksheet
Dim cell As Range, rng As Range, A As Range, LastRow As Long
Set Sa = ThisWorkbook.Worksheets("Sales")
LastRow = Cells(Rows.Count, "B").End(xlUp).Row
Set rng = Sa.Range("B1:B" & LastRow)
For Each cell In rng
Set A = cell.Offset(0, -1)
If cell.Value > 3 Then
A.Value = A.Value / 2
A.Interior.ColorIndex = 3
End If
Next cell
End Sub
Try this code:
Sub halveandcolorchange()
Dim Sa As Worksheet
Dim cell As Range, rng As Range, A As Range, LastRow As Long
Dim B As Double
Set Sa = ThisWorkbook.Worksheets("Sales")
LastRow = Sa.Cells(Sa.Rows.Count, "B").End(xlUp).Row
Set rng = Sa.Range("B1:B" & LastRow)
For Each cell In rng
Set A = cell.Offset(0, -1)
If cell.Value > 3 Then
B = cell.Value
A.Value = B / 2
A.Interior.ColorIndex = 3
End If
Next cell
End Sub
I have been trying to create a function which checks that if Col"B" <> Empty then copy the third cell which is under the same row.
I have this Data:
Where from i want to copy the Col"D" highlighted cells and paste them into same row where Col"B" <> empty.
Here is the final result. Your help will be appreciated in this regards.
Option Explicit
Sub CopyPasting()
Dim ws As Worksheet
Dim r As Long
Dim LastRow As Long
Dim n As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
LastRow = .Range("D" & .Rows.Count).End(xlUp).Row
For r = LastRow To 2 Step -2
If .Cells(r, "B") <> "" Then
.Rows(r + "D").Copy
.Rows(r + "D").PasteSpecial
n = n + 1
End If
Next
End With
End Sub
Please, try the next code:
Sub testRetOffset3()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, c As Range
Set sh = ActiveSheet 'use here the sheet you need
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row 'last sheet row
On Error Resume Next 'if not empty cells in column, it will not return the range and raise an error
Set rngV = sh.Range("B2:B" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub 'stop the code if run on a wrong sheet, without empty cells in column B:B
For Each c In rngV.cells 'iterate between the discontinuous range cells
If rngFin Is Nothing Then 'if the final range is not set (first time)
Set rngFin = c.Offset(3, 2) 'set the range = the Offset necessary cell
Else
Set rngFin = Union(rngFin, c.Offset(3, 2)) 'make a Union between existing range and the Offset necessary cell
End If
Next
If Not rngFin Is Nothing Then 'copy both ranges in consecutive columns
rngV.Copy sh.Range("F2")
rngFin.Copy sh.Range("G2")
End If
End Sub
It will return in columns F:G, starting from the second row. It is easy to modify the range where to return...
You can even clear the existing processed columns and return in B:C, or in another sheet.
Edited:
In order to solve the last request, please use the next code:
Sub testRetOffsetMoreRows()
Dim sh As Worksheet, lastR As Long, rngV As Range, rngFin As Range, A As Range
Set sh = ActiveSheet
lastR = sh.Range("B" & sh.rows.count).End(xlUp).row
On Error Resume Next
Set rngV = sh.Range("A2:D" & lastR).SpecialCells(xlCellTypeConstants)
On Error GoTo 0
If rngV Is Nothing Then Exit Sub
For Each A In rngV.Areas 'iterate between the range areas
If rngFin Is Nothing Then
Set rngFin = A.cells(1,2).Offset(3, 3) 'use the second cell of the area
Else
Set rngFin = Union(rngFin, A.cells(1,2).Offset(3, 3))
End If
Next
If Not rngFin Is Nothing Then
rngV.Copy sh.Range("H2")
rngFin.Copy sh.Range("L2")
End If
End Sub
But take care to have continuous ranges when have a value in column B:B. Otherwise, the code may fail... The areas property will return differently.
I wasn't sure where you wanted the output, this will put it into a sheet called "Sheet2". (You'll have to make that before running the code it won't create it for you.)
Dim i As Long
Dim j As Long
Dim lr As Long
Dim srcWS As Worksheet
Dim destWS As Worksheet
Set srcWS = ThisWorkbook.Sheets("Sheet1")
Set destWS = ThisWorkbook.Sheets("Sheet2")
With srcWS
lr = .Cells(.Rows.Count, 4).End(xlUp).Row
j = 2
For i = 2 To lr
If .Cells(i, 2).Value <> "" Then
destWS.Cells(j, 1).Value = .Cells(i, 2).Value
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
j = j + 1
End If
Next i
End With
If you need the colors copied over as well then use this:
.Cells(i, 4).Offset(2, 0).Copy
destWS.Cells(j, 2).PasteSpecial xlPasteAll
instead of:
destWS.Cells(j, 2).Value = .Cells(i, 4).Offset(2, 0).Value
I am very new to VBA and just beginning to learn. I have a code here to match all the cells of the "M" column in Sheet1 and Sheet3, and delete all the rows from Sheet1 that contain any value from Sheet3's "M" column.
If I go through it using F8, I do not get any error but when I assign it to a button, it fails at run-time with 'Object Required' error. I tried a few things that I found online, but none of them seem to work.
Below is my code. Any help would be much appreciated.
Sub DeleteRows()
Dim rng As Range
Dim rng2 As Range
Dim cell As Object
Dim cell2 As Object
Set rng = Sheets("Sheet1").Range("M2:M1541")
Set rng2 = Sheets("Sheet3").Range("M2:M30")
For Each cell In rng
For Each cell2 In rng2
If cell.Value = cell2.Value Then
cell.EntireRow.Delete
End If
Next
Next
Application.ScreenUpdating = True
End Sub
Thanks in advance!
You can loop through the cells in sheet2 and filter for those items in sheet1.
Then you would not be double looping.
Sub Button1_Click()
Dim ws As Worksheet, sh As Worksheet
Dim LstRw As Long, Rng As Range, Frng As Range, c As Range, Nrng As Range
Set ws = Sheets("Sheet2")
Set sh = Sheets("Sheet1")
With ws
LstRw = .Cells(.Rows.Count, "M").End(xlUp).Row
Set Rng = .Range("M2:M" & LstRw)
End With
With sh
Set Frng = .Range("M2:M" & .Cells(.Rows.Count, "M").End(xlUp).Row)
For Each c In Rng.Cells
.Range("M1").AutoFilter Field:=1, Criteria1:=c
On Error Resume Next
Set Nrng = Frng.SpecialCells(xlVisible)
On Error GoTo 0
If Nrng Is Nothing Then
Else
Frng.EntireRow.Delete
End If
Next c
.AutoFilterMode = False
End With
End Sub
Sub iterateThroughAll()
ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range
Dim colRange As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
'Find Last column in current row
LastCol = 1 'wks.Cells(rrow, wks.Columns.Count).End(xlToLeft).Column
Set colRange = wks.Range(wks.Cells(rrow, 1), wks.Cells(rrow, LastCol)) <-------------- I get a Run-time error 1004 Application defined or object defined error.
'Loop through all cells in row up to last col
For Each cell In colRange
'Do something to each cell
Debug.Print (cell.Value)
Next cell
Next rrow
ScreenUpdating = True
End Sub
I get an Application-defined or object-defined error. The code looks okay but not sure why its not working here.
I am trying to get all the used cells in Column A
Option Explicit
Sub iterateThroughAll()
Application.ScreenUpdating = False
Dim wks As Worksheet
Set wks = ActiveSheet
Dim rowRange As Range, rrow As Range
Dim colRange As Range, Cell As Range
Dim LastCol As Long
Dim LastRow As Long
LastRow = wks.Cells(wks.Rows.Count, "A").End(xlUp).Row
Set rowRange = wks.Range("A1:A" & LastRow)
'Loop through each row
For Each rrow In rowRange
'Find Last column in current row
LastCol = 1 'wks.Cells(rrow, wks.Columns.Count).End(xlToLeft).Column
Set colRange = wks.Range(wks.Cells(rrow.Row, 1), wks.Cells(rrow.Row, LastCol))
'Loop through all cells in row up to last col
For Each Cell In colRange
'Do something to each cell
Debug.Print (Cell.Value)
Next Cell
Next rrow
Application.ScreenUpdating = True
End Sub
I am new to VBA.
For each cell in columns("c:c")
If cell.value = "TRUE" Then
'vba is required for selecting corresponding cells in columns A and B
Next cell
Else:
exit sub
End if
end sub
please make suitable corrections
Try this one:
Sub test()
Dim lastrow As Long
Dim c As Range, rng As Range
'change Sheet1 to suit
With ThisWorkbook.Worksheets("Sheet1")
lastrow = .Cells(.Rows.Count, "C").End(xlUp).Row
For Each c In .Range("C1:C" & lastrow)
If UCase(c.Text) = "FALSE" Then
If rng Is Nothing Then
Set rng = .Range("A" & c.Row).Resize(, 2)
Else
Set rng = Union(rng, .Range("A" & c.Row).Resize(, 2))
End If
End If
Next c
End With
If Not rng Is Nothing Then rng.Select
End Sub