I'm trying to round every populate cell in column AD:AD to 4 decimals and ends when the next cell is blank.
I thought something like this would work but it errors out on the cell.value.
Sub Round_4()
For Each cell In [AD:AD]
If cell = "" Then Exit Sub
cell.Value = WorksheetFunction.Round(cell.Value, 4)
Next cell
End Sub
Any suggestions?
You could work only down to the first empty cell with
Range("AD1", Range("AD1").End(xlDown)).Value = Evaluate("round(" & Range("AD1", Range("AD1").End(xlDown)).Address & ",4)")
Note this is using Activesheet reference. You can wrap in a With statement giving the parent sheet.
You could do this:
Dim myCell As Range
Dim myRange As Range
Set myRange = Excel.Application.ThisWorkbook.Worksheets(worksheetNameGoesHereInDoubleQuotes).Range("AD:AD")
For Each myCell In myRange
If Not IsEmpty(myCell) Then
myCell.Value = Application.WorksheetFunction.Round(CDbl(myCell.Value), 4)
'me being lazy with my range assignment
ElseIf IsEmpty(myCell) Then
Exit For
End If
Next
Related
I want to convert to upper case a selected range in Excel.
Here's my code
Dim rng As Range
Set rng = Selection
rng.Value = rng.Parent.Evaluate("INDEX(UPPER(" & rng.Address & "),)")
It works on a large range, but gives the #VALUE! error when only a single cell is selected.
Cut your selection down to the used range in case you have selected an entire column or row.
Process a single cell if you only have a single cell selected; process in bulk for any multiple cell selections.
Dim rng As Range
Set rng = Intersect(Selection, Selection.Parent.UsedRange)
If rng.Cells.Count > 1 Then
rng.Value = Application.Evaluate("INDEX(UPPER(" & rng.Address & "),)")
Else
rng = UCase(rng.Value)
End If
This code will work for single cell or a selection:
Sub ChangeCellCase()
Dim CellCase
For Each CellCase In Selection
CellCase.Value = UCase(CellCase.Value)
Next
End Sub
According to this website.
I think this should work:
Dim cell As Range
For Each cell In xxxSheet.Range("B:B").SpecialCells(xlCellTypeFormulas, xlNumbers)
'Do sth.
Next
which does not work. Is there something missing?
This should be working solution:
For Each cell In xxxSheet.Range("B:B")
If Not IsEmpty(cell) Then
'do sth
End If
Next
Also, if you want to loop until last filled cell, you could use following:
xxxSheet.Range("B1:B" & Cells(Rows.Count, 2).End(xlUp).Row)
instead of
xxxSheet.Range("B:B")
It does not work, because you do not have formulas on column B. Put some formulas and some constants and try this:
Option Explicit
Public Sub TestMe()
Dim myCell As Range
Dim myRange As Range
Set myRange = Worksheets(1).Columns("B:B").SpecialCells(xlCellTypeFormulas, xlNumbers)
For Each myCell In myRange
Debug.Print myCell.Address
Next
Set myRange = Worksheets(1).Columns("B:B").SpecialCells(xlCellTypeConstants, xlNumbers)
For Each myCell In myRange
Debug.Print myCell.Address
Next
End Sub
The first loop would print the addresses of the formula cells, the second the addresses of the constants.
This is the ozgrid explanation about SpecialCells:
http://www.ozgrid.com/VBA/special-cells.htm
The problem is SpecialCells(xlCellTypeFormulas, xlNumbers) is returning only cells with formulas that make numbers (ie. =1+2).
To keep things efficient, you only need to check up to the last filled row
For Each cell In xxxSheet.Range("B1", Cells(Rows.Count, 2).End(xlUp))
If Not IsEmpty(cell) Then
'Do sth.
End If
Next
If you really want you can use SpecialCells() to have a range containing no blanks to loop through. If you only have formulas or only constants, you could use SpecialCells(xlFormulas) or SpecialCells(xlConstants) respectively, but for a more general use case you will have to do do a combination of the two.
Dim cell As Range
Dim searchRange As Range
' SpecialCells errors when there aren't cells instead of giving a useful value
On Error Resume Next
Set searchRange = xxxSheet.Range("B:B").SpecialCells(xlFormulas)
Set searchRange = xxxSheet.Range("B:B").SpecialCells(xlConstants)
Set searchRange = Union(xxxSheet.Range("B:B").SpecialCells(xlConstants), _
xxxSheet.Range("B:B").SpecialCells(xlFormulas))
On Error GoTo 0
If searchRange Is Not Nothing Then ' Only continue if no blanks
For Each cell In searchRange
'Do sth.
Next
End If
I just want to know how to loop through the non blank cells on Column A. What I'm trying to do is copy the contents on [A1:B1] to be added on top of each non blank cells on Column A. So far I have counted the non blank cells on column A but I'm stuck. I know that an Offset function should be used for this.
Here's my code so far:
Dim NonBlank as Long
NonBlank = WorksheetFunction.CountA(Worksheet(1).[A:A])
For i = 1 to NonBlank
[A1:B1].Copy Offset(1,0). "I'm stuck here"
Next i
If you are trying to fill the headers for each Product, try this...
Sub FillHeaders()
Dim lr As Long
Dim Rng As Range
lr = ActiveSheet.UsedRange.Rows.Count
Application.ScreenUpdating = False
On Error Resume Next
Range("A1:B1").Copy
For Each Rng In Range("A3:A" & lr).SpecialCells(xlCellTypeConstants, 2).Areas
If Rng.Cells(1).Value <> Range("A1").Value Then
Rng.Cells(1).Offset(-1, 0).PasteSpecial xlPasteAll
End If
Next Rng
Application.CutCopyMode = 0
Application.ScreenUpdating = True
End Sub
As example to simulate the effect of Ctrl-Down from Cell A1 and display the Address, Value in the Immediate Window:
Sub HopToNextNonBlankCellBelow()
Dim oRng As Range
Set oRng = Range("A1")
Debug.Print "Cell Address", "Cell Value"
Do
Set oRng = oRng.End(xlDown)
If Not IsEmpty(oRng) Then Debug.Print oRng.Address(0, 0), oRng.Value
Loop Until oRng.Row = Rows.Count
Set oRng = Nothing
End Sub
Try this... I've (probably) overcounted the rows at 1000, but it likely won't make a difference with your performance. If you wanted to be more precise, there are hundreds of articles on how to find the last row of a range. As for the Offset function, it references a cell in relation to the one we're looping through. In the example below, the code is saying cell.offset(0,1) which means one cell to the right of the cell we are currently looping through. A clearer (less loopy!) example would be if you typed: Range("A10").offset(0,1) it would be the same as typing Range("B10")
Dim Cell As Range
For Each Cell In Range("A2:A1000").Cells
If Not IsEmpty(Cell) Then
Cell.Offset(0, 1).Value = Cell.Value
End If
Next Cell
I have section title cells set at 10 pt font while all other data is set at 9 point font in column A. I am trying to write a vba macro to loop through column A to move each title cell down one row(because the csv leaves a blank cell below them) then move on to the next title cell in the column. Here is my attempt but I'm not sure what I'm doing wrong here.
Sub FontSpacing()
Dim Fnt As Range
For Each Fnt In Range("A8:A5000")
If Fnt.Font.Size = "10" Then
ActiveCell.Cut Destination:=ActiveCell.Offset(",1")
End If
Next
Try this
Sub FontSpacing()
Dim r As Range
For Each r In ThisWorkbook.Worksheets("Sheet1").Range("A8:A5000")
If r.Font.Size = 10 Then
r.Offset(1,0).Value = r.Value
r.Value = vbNullString
End If
Next r
End Sub
The issues:
Offset(",1") shouldn't have the speech marks. I.e. it should be Offset(0,1). In fact, if you want to paste to the row below, then it should be Offset(1,0).
Avoid using ActiveCell. It's not the cell that is looping through your range, it's just the cell that was active on the worksheet when you ran the sub.
Fnt is a bad name for a range, it's probably the reason you got confused. When declaring (dimensioning) a range, try to give it a name that makes it clear you're working with a range.
Extra:
Fully qualify your range reference to avoid an implicit reference to the ActiveSheet e.g. ThisWorkbook.Worksheets("Sheet1").Range("A1").
Avoid cutting an pasting by setting the Value directly
Your indentation is out, which makes it look like a complete Sub, but it's missing the End Sub.
Not sure if you meant 1 Row below or 1 Column right so:
To shift 1 Column:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
cell.Offset(0, 1).Value = cell.Value
cell.Clear
End If
Next
End Sub
To shift 1 Row:
Sub FontSpacing()
Dim rng As Range, cell As Range
Set rng = Range("A1:A5000")
For Each cell In rng
If cell.Font.Size = "10" Then
a = cell.Row + 1
Rows(a & ":" & a).Insert Shift:=xlDown, CopyOrigin:=1
cell.Offset(1, 0).Value = cell.Value
cell.Offset(1, 0).Font.Size = "11"
cell.Clear
End If
Next
End Sub
I'm looking for some code that will look at Column A and as long as the cell in Column A is not blank, then the corresponding cell in Column B will equal a specific value.
So if Cell A1 <> "" then Cell B1.Value = "MyText"
And repeat until a cell in Column A is blank or empty.
To add a little more clarification, I have looked through the various loop questions asked and answered here. They were somewhat helpful. However, I'm unclear on how to get the loop to go through Column A to verify that each cell in Column A isn't blank AND in the corresponding cell in Column B, add some text that I specify.
Also, this will need to be part of a VBA macro and not part of a cell formula such as =IF
If you really want a vba solution you can loop through a range like this:
Sub Check()
Dim dat As Variant
Dim rng As Range
Dim i As Long
Set rng = Range("A1:A100")
dat = rng
For i = LBound(dat, 1) To UBound(dat, 1)
If dat(i, 1) <> "" Then
rng(i, 2).Value = "My Text"
End If
Next
End Sub
*EDIT*
Instead of using varients you can just loop through the range like this:
Sub Check()
Dim rng As Range
Dim i As Long
'Set the range in column A you want to loop through
Set rng = Range("A1:A100")
For Each cell In rng
'test if cell is empty
If cell.Value <> "" Then
'write to adjacent cell
cell.Offset(0, 1).Value = "My Text"
End If
Next
End Sub
Another way (Using Formulas in VBA). I guess this is the shortest VBA code as well?
Sub Sample()
Dim ws As Worksheet
Dim lRow As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
With ws
lRow = .Range("A" & .Rows.Count).End(xlUp).Row
.Range("B1:B" & lRow).Formula = "=If(A1<>"""",""My Text"","""")"
.Range("B1:B" & lRow).Value = .Range("B1:B" & lRow).Value
End With
End Sub
A simpler way to do this would be:
Sub populateB()
For Each Cel in Range("A1:A100")
If Cel.value <> "" Then Cel.Offset(0, 1).value = "Your Text"
Next
End Sub
Use the function IF :
=IF ( logical_test, value_if_true, value_if_false )