I am building a macro which finds a header and then offsetting it by 1 row below i want to fill a value to the entire column. But when i Run the macro is changing the value of the offset to the Required but once it got to Selection.filldown its copying the header in the place of offset value. And also i am unable to figure out how to skip if the selection is not found. Can anyone help out with this?
Sub Macro7()
Rows("3:3").Select
Selection.Find(What:="item_width").Select
Selection.Offset(1, 0).Select
ActiveCell.FormulaR1C1 = "1"
Selection.FillDown
End Sub
As Christmas007 said, remove the .select and .activate:
Sub Macro7()
Dim rng As Range
Dim rws As Long
rws = Range("A" & Rows.Count).End(xlUp).Row - 2
Set rng = Rows("3:3").Find(What:="item_width")
If Not rng Is Nothing Then
rng.Offset(1, 0).FormulaR1C1 = "1"
rng.Offset(1, 0).Resize(rws).FillDown
End If
End Sub
Also the way you had the fill since it is only one cell it fills it with the cells directly above. To fill a range you need to dictated the range extents. The above is one way.
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 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
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
Hello I want to delete empty rows of a table and i am finding issues.
Dim rng As Range
rng = Sheets("NewForecast").ListObjects("Table").Range.Select
If rng.Rows = 0 Then
rng.EntireRow.Delete
End If
I don't know how to write it, I tried several ways, looked for here, but could not find an specific solution. I want delete if the Row is completely empty. Any help much appreciated!
I managed to work on that! Thanks for all who actually opened my mind. Look below, it is simple and doing what I want, macro goes faster too.
Range("Table[#Headers]").Select
Selection.AutoFilter
ActiveSheet.ListObjects("Table").Range.AutoFilter Field:=2, Criteria1:="="
Range("Table").Select
Range(Selection, Selection.End(xlToRight)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.EntireRow.Delete
Range("Table[#Headers]").Select
ActiveSheet.ShowAllData
Try something like
Dim ws as Worksheet
Set ws = ActiveWorkbook.Worksheets("SHEET NAME HERE")
Dim lRow as long
Dim rng as range
lRow = ws.Range("A" & Rows.Count).end(xlUp).row
'Assuming your table starts in column A, put in start/end row numbers
For each rng in ws.Range("A1:A" & lRow)
If ws.Range("A" & rng.row) = vbNullString then
ws.Rows(rng.row).Delete
End if
Next rng
When trying to delete rows in a sheet, always use a backward For loop (For i = 100 to 1 Step -1 for instance).
When checking if a certain Range or Row is completely empty, the WorksheetFunction.CountA comes in quite handy.
Option Explicit
Sub DeleteEmptyRows()
Dim Rng As Range
Dim LastRow As Long
Dim lRow As Long
With Sheets("NewForecast")
Set Rng = .ListObjects("Table").Range
' find last row in "Table"
LastRow = .ListObjects("Table").Range.Rows.Count
' loop through all "Table" rows, loop backwards when deleting
For lRow = LastRow To 2 Step -1
' use CountA to check if entire row is empty
If WorksheetFunction.CountA(.Rows(lRow)) = 0 Then
.Rows(lRow).EntireRow.Delete
End If
Next
End With
End Sub
This is possible without looping.
Filter the table so the values showing are the ones you want to delete
Find the first "deletable" row (where cell.value = "") in the last column of the sheet (will most typically be blank, most people don't use the last column),
Then find the last "deletable" row (where cell.value = "").
Then use this:
Rows(firstRow & ":" & lastRow).EntireRow.Delete
This can be expensive (take a long time) if your field of values is very large but works on sheets as well as tables and is faster (better) than looping.
I need to create a macro that will duplicate all the rows of a table when a certain column is true.
I recorded a macro and it gave me this:
ActiveSheet.ListObjects("Table1").Range.AutoFilter Field:=4, Criteria1:= "TRUE"
Range("Table1").Select
Application.CutCopyMode = False
Selection.Copy
Range("A22").Select 'To be replaced with a method that finds the last cell.
'Selection.End(xlDown).Select gives me the last row in the table, but I want the one under that.
ActiveSheet.Paste
ActiveWindow.SmallScroll Down:=12
However before I delve into it I would like to know what would be the best/fastest approach?
Something like this would work. Modify as needed
Sub david()
Application.CutCopyMode = True
Dim lastrow As Integer
Dim rCell As Range
lastrow = ActiveSheet.ListObjects("Table1").ListRows.Count
For Each rCell In ActiveSheet.ListObjects("Table1").ListColumns(2).DataBodyRange
If rCell.Value = "True" Then
ActiveSheet.ListObjects("Table1").ListRows.Add
rCell.EntireRow.Copy
ActiveSheet.ListObjects("Table1").ListRows(lastrow + 1).Range.PasteSpecial Paste:=xlPasteValues
lastrow = lastrow + 1
End If
Next
Application.CutCopyMode = False
End Sub
If you have other data on the same row in the table's sheet, you might need to copy a specific range rather than .entirerow as it will pick up data outside the table.
These two SO threads may help if you want to clean it up some- Copy and Paste Table Row and Add row.
I ended up writing this, much faster. There's some logic which avoids copying the first column (which is a Row() formula. You can probably do without it).
Sub DuplicateRows(tableToDuplicate As String, columnToDetermineIfRowNeedsDuplication As Integer)
Application.DisplayAlerts = False
'Excel is more efficient when copying whole ranges at once rather than row by row.
Dim sourceRange As Range, destRange As Range
Dim rowsToDelete As Range
Set sourceRange = Range(tableToDuplicate)
'Copy source range except row num. Start at bottom of source range. Start at offset x + so that row number is not copied.
Set sourceRange = sourceRange.Resize(sourceRange.Rows.Count, sourceRange.Columns.Count - 1)
Set sourceRange = sourceRange.Offset(0, 1) ' We don't need to copy the first column.
Set destRange = sourceRange.Offset(sourceRange.Rows.Count, 0)
destRange.Value = sourceRange.Value 'Duplicate all values.
Set rowsToDelete = destRange 'Get complete table now, unfiltered.
rowsToDelete.AutoFilter columnToDetermineIfRowNeedsDuplication, Criteria1:="=FALSE" ' Find which ones we must delete.
Set rowsToDelete = rowsToDelete.Offset(0, -1)
Set rowsToDelete = rowsToDelete.Resize(rowsToDelete.Rows.Count, rowsToDelete.Columns.Count + 1)
rowsToDelete.Rows.Delete
End Sub