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
Related
I'm trying to write a macro that removes rows with the condition that the string in the cells in column A contains "--" or "-4" or "" (empty). I'd do it with a normal filter, but that gives me max 2 conditions.
Sub Delete_Rows()
Dim cell As Range
For Each cell In Range("A:A")
If cell.Value = "*--*" Or cell.Value = "*-4*" Then
cell.EntireRow.Delete
End If
Next cell
End Sub
What am I doing wrong?
Please, test the next version. It uses an array for iteration and a Union range to delete rows at once, at the end of the code:
Sub Delete_Rows3Cond()
Dim sh As Worksheet, lastR As Long, rngDel As Range, arr, i As Long
Set sh = ActiveSheet
lastR = sh.Range("A" & sh.rows.count).End(xlUp).row
arr = sh.Range("A1:A" & lastR).Value2 'place the range in an array for faster iteration/processing only in memory
For i = 1 To UBound(arr)
If arr(i, 1) = "" Or arr(i, 1) Like "*--*" Or arr(i, 1) Like "*-4*" Then
addToRange rngDel, sh.Range("A" & i) 'create the union range
End If
Next
If Not rngDel Is Nothing Then rngDel.EntireRow.Delete xlUp
End Sub
Private Sub addToRange(rngU As Range, Rng As Range) 'I creates the Union range
If rngU Is Nothing Then
Set rngU = Rng
Else
Set rngU = Union(rngU, Rng)
End If
End Sub
Deleting a row at a time, takes a lot of time and you need to process only the range containing data...
Please, send some feedback after testing it.
= checks for identical strings, so unless you have a cell containing "*--*" or "*-4*", the If-clause will never be true. You will have to use the like-operator:
If cell.Value like "*--*" Or cell.Value like "*-4*" Then
Two remarks:
Your code will loop through the whole Excel sheet (which contains 1'048'576 rows) so that will run a very long time. And, even worse, if you add the check for empty cells to delete a row, it will delete one million rows and it would look as if Excel/VBA is frozen. Therefore you need to figure out the last row before you run the code. More on this at Find last used cell in Excel VBA
And you need to be aware the that code will run on the active sheet - the sheet that currently has the focus. You should always specify the sheet (and workbook) where you want to code to work with. Don't go down the path to Select the sheet to make if active. For more details, see How to avoid using Select in Excel VBA
Sub Delete_Rows()
Dim cell As Range, lastRow As Long
' Replace the following line with the workbook you want to work with
With ThisWorkbook.Sheets(1)
lastRow = .Cells(.Rows.Count, "A").End(xlUp).row
For Each cell In .Range("A1:A" & lastRow)
If cell.Value Like "*--*" Or cell.Value Like "*-4*" Then
cell.EntireRow.Delete
End If
Next cell
End With
End Sub
You can use the Like operator instead of "=" to perform the comparison. Consider the following the code:
Sub Delete_Rows()
Dim cell As Range
For Each cell In Range("A:A")
If cell.Value Like "*--*" Or cell.Value Like "*-4*" Then
cell.EntireRow.Delete
End If
Next cell
End Sub
You can also read more about the like operator here for example: https://www.wallstreetmojo.com/vba-like/
I hope this helps :D
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
So I am having a worksheet with 16 columns. And I would like to find out the cells with font color is vbRed. Lets say Range("A5") is the found cell then I would like to copy and paste the entire row into the next row in the current worksheet.
As I am writing Macro, I found my program will keep looping on the row that I copied and pasted. And also I am not sure whether I can use loop, copy and paste together with find method. I will strong appreciate if anyone can help with this.
With my current code:
Sub CopyRow()
Dim Row As Long
Row = ActiveSheet.Range("A1", ActiveSheet.Range("A1").End(xlDown)).Rows.Count
Sheets("Sheet1").Activate
Dim rng As Range
Set rng = Range("A1:A" & Row)
For Each cel In rng
If cel.Font.Color = vbRed Then
cel.Rows.EntireRow.Insert Shift:=xlDown
cel.EntireRow.Copy cel.Offset(-1).EntireRow
cel.Offset(1, 0).Select
End If
Next cel
End Sub
There's infinite loop....
To select the first cell empty in a column :
Range("YOUR COLUMN" & Rows.Count).End(xlUp).Offset(1).Select
If your column A is always filled, you can base your macro on it and then paste the entire row you copied.
Dim SrchRngA as range
Set SrchRngA = Range("a16:a500")
For Each cel In SrchRngA
If InStr(1, cel.Value, "AB") > 0 Then 'search for "AB"
cel.offset(1,0).value = cel.value 'replace next row with current cell value
end if
next cel
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 am writing a VBA code that will open a specific worksheet in my workbook in Excel, and then find the cell in Column A that has the value "TOTAL". This then must be set as the ActiveCell, so that the rest of my macro can perform actions on the row containing this cell.
I want it so that when the user runs the macro, this cell is specifically chosen right off the bat. The position of this cell will change after the macro is run, so I need it to work no matter what cell this value is in. Everytime the macro runs, a new row is added above the row containing "TOTAL" and therefore the position of this cell is ever-changing.
So far I have come up with this, just from readin through forums. It still doesn't work, but I'm new to this language and I can't determine where the error is.
Sub Macro2()
Dim C As Range
Worksheets("Project Total").Select
With Selection
C = .Find("TOTAL", After:=Range("A2"), MatchCase:=True)
End With
End Sub
Try this:
Sub Macro2()
Dim cl As Range
With Worksheets("Project Total").Cells
Set cl = .Find("TOTAL", After:=.Range("A2"), LookIn:=xlValues)
If Not cl Is Nothing Then
cl.Select
End If
End With
End Sub
Try this:
Sub activateCellContainingTOTAL()
'Go to the worksheet
Worsheets("Project Total").Activate
'Start going down column A to see if you find the total
dim loopBool as Boolean
loopBool = True
Worksheets("Project Total").Range("A1").Activate
Do While loopBool=True
if Activecell.value = "TOTAL" then
loop = false
else
activecell.offset(1, 0).Activate
end if
loop
End sub
Sub Getvaluesfromeachcolumns()
Dim loopcounter As Integer
Dim loopcounter1 As Integer
Dim dumvalue As String
Dim rrange As Range
dumvalue = Activecell.value 'you can replace your cell reference or any value which you want to search. also you can use input method.'
loopcounter1 = Range("A1:C1").Count
For loopcounter = 1 To loopcounter1
Cells(1, loopcounter).Select
Range(ActiveCell.Address).Select ' to know the active cell and address
Set rrange = Range(ActiveCell.Address, ActiveCell.End(xlDown)).Find(dumvalue)
rrange.Select
Next loopcounter
End Sub