I have an excel worksheet with example data in column A like
row 1 has a
row 2 has b
row 3 has c
row 4
row 5 has d
Using my macro i want to add a new row above where ever there is data in the selected cell. As row 1 cell has data "a" macro should add a row and goto next cell. row 4 has no data so it should skip this row check the next
i have macro below
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
FinalRow1 = FinalRow + FinalRow
ActiveSheet.Range("A1").Select
For i = 1 To FinalRow1
If Cells(i, 1).Value = vbNullString Then
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
Else
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(rowOffset:=2, columnOffset:=0).Activate
'ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
End If
Next i
It seems to work some times and other times it simply does not add the expectd row.
Can someone please help
The FASTEST and DIRTY answer is:
FinalRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
FinalRow1 = FinalRow + FinalRow
ActiveSheet.Range("A1").Select
For i = 1 To FinalRow1
If Cells(i, 1).Value = vbNullString Then
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
Else
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(rowOffset:=2, columnOffset:=0).Activate
I = I +1 ' BECAUSE you have increased the next row number by 2
End If
Next i
The real problem: you have a loop with 2 running data:
the loop varable I
AND the actual position of ActiveCell
When you insert a row, they will not show the same data anymore.
It would be much nicer
if you forget For loop and rely only ActiveCell.Offset position
OR if you forget ActiveCell.Offset and rely only the For loop I variable.
Either way is OK, but you mixed - and in my answer I left this mix, just focused that loop varable I and ActiveCell.Offset should be in offset.. ;-)
Made some changes in your code. But it is always better to loop from last row to first row.
Sub Demo()
Dim flag As Boolean
finalrow = Cells(Rows.count, 1).End(xlUp).Row + 1
FinalRow1 = finalrow + finalrow
ActiveSheet.Range("A1").Select
flag = False
For i = 1 To FinalRow1
If ActiveCell.Value = vbNullString Then
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
flag = True
Else
If flag = False Then
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(rowOffset:=2, columnOffset:=0).Activate
Else
flag = False
ActiveCell.Offset(rowOffset:=1, columnOffset:=0).Activate
End If
End If
Next i
End Sub
One drawback of this code is that it loops for few extra number of times when not needed, will work on it in sometime.
Related
Good morning,
currently I have this code to delete rows without due date (Column J) and amount paid=0 (Column H).
Sub delete_rows()
Range("A1").End(xlDown).Select
Sheets("AA").Select
Range("J2").Select
ActiveCell.FormulaR1C1 = "=IF(RC[-5]=0,"""",RC[-5])"
Range("J2").Select
Selection.AutoFill Destination:=Range("J2:J500"), Type:=xlFillDefault
Range("J2").End(xlDown).Select
Range("K2").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "J").End(xlUp).Row To 2 Step -1
If .Cells(line, "J") = "" Then
.Rows(line).Delete
End If
Next linha
End With
Application.ScreenUpdating = True
ActiveCell.FormulaR1C1 = "=IF(RC[-4]="""","""",RC[-4])"
Range("K2").Select
Selection.AutoFill Destination:=Range("K2:K500"), Type:=xlFillDefault
Range("K2").End(xlDown).Select
Range("J1").Select
Application.ScreenUpdating = False
With Sheet2
For line = .Cells(.Rows.Count, "K").End(xlUp).Row To 2 Step -1
If .Cells(line, "K") = "" Then
.Rows(line).Delete
End If
Next line
End With
Application.ScreenUpdating = True
End sub()
I created a code with a defined number of lines...however it takes a long time for the code to run, because sometimes the number of lines is small and it always runs the 500 lines. What's the way to set the code so that it looks for the last filled row in column A, and then eliminate the rows where column H has values =0 and in column J no values?
Please check: find last cell. Also have a look at: avoid select.
Afterwards, I think you should be able to understand the following code, which should get you the required result:
Sub test()
Application.ScreenUpdating = False
'declare your variables
Dim ws As Worksheet
Dim Rng1 As Range, Rng2 As Range
Dim i As Long, lastRow As Long
Set ws = Sheets("AA")
With ws
'get last row in
lastRow = .Range("A" & .Rows.Count).End(xlUp).Row
'set ranges for loop
Set Rng1 = Range(.Cells(2, "H"), .Cells(lastRow, "H"))
Set Rng2 = Range(.Cells(2, "J"), .Cells(lastRow, "J"))
'reverse loop
For i = Rng1.Rows.Count To 1 Step -1
'check conditions for cell in "H" and "J"
If Rng1.Cells(i) = 0 And Rng2.Cells(i) = "" Then
'defined ranges start at row 2, hence +1
ws.Rows(i + 1).Delete
End If
Next i
End With
Application.ScreenUpdating = True
End Sub
my goal is to delete rows with column 3 with the cell value that has inventory (>0) and column 4 that has the cell value TRUE in the current sheet. I tried to use the code to this website and I'm pretty sure I did something wrong where it says ActiveSheet.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Public Sub FilterStock()
ActiveSheet.Range("A1").AutoFilter Field:=4, Criteria1:="TRUE"
ActiveSheet.Range("A1").AutoFilter Field:=3, Criteria1:=">0"
Application.DisplayAlerts = False
ActiveSheet.DataBodyRange.SpecialCells(xlCellTypeVisible).Delete
Application.DisplayAlerts = True
ActiveSheet.AutoFilter.ShowAllData
End Sub
This code worked for me:
Sub DeletelRows()
Dim lastRow As Long
Dim debug1 As Variant
Dim debug2 As Variant
'Find the last non-blank cell in column C
lastRow = Cells(Rows.Count, 3).End(xlUp).Row
For x = lastRow To 2 Step -1 'Start at bottom and go up to avoid complications when the row is deleted.
debug1 = Cells(x, 3).Value 'You can set breakpoints to see what the values are.
debug2 = Cells(x, 4).Value
If (Cells(x, 3).Value > 0 And UCase(Cells(x, 4).Value) = "TRUE") Then
Rows(x).Delete
End If
Next x
End Sub
I have a Workbook in which there is a sheet named "tracker" that shows certain actionables that need to be closed by team member by target date. I can do it on excel using filters. But I tried ti build a VBA code to automate the process which is
Search for Status of action in column 28. If it is "Open" then Check if "target date" in column 43 is exited as of today. I put today date in column 46. If Target date is exceeded then I want that row to be copy pasted in another worksheet "Open Items". The code should move to next item in 2 situations, either the status is "closed" of Target date is yet to arrive.
Following is code I wrote. The code is executed properly but I get only the last row as output in Open items sheet. The code do not seem to check for status or dates properly
Sub OpenItems()
Application.ScreenUpdating = False
Dim i As Long
Dim Lastrow As Long
Sheets("Open Items").Select
Cells.Select
'Range("E16").Activate
Selection.Delete Shift:=xlUp
Sheets("Observation Tracker").Select
Range("A2").Select
Sheets("Observation Tracker").Activate
Lastrow = Cells(Rows.Count, "AQ").End(xlUp).Row
Dim Lastrowa As Long
Lastrowa = Sheets("Observation Tracker").Cells(Rows.Count,"AU").End(xlUp).Row + 1
For i = 2 To Lastrow
If Cells(i, 28).Value = "Open" Then
If Cells(i, 43).Value < Cells(i, 46).Value Then
Rows(i).Copy Sheets("Open items").Rows(Lastrow)
i = i + 1
End If
End If
Next
Sheets("Observation Tracker").Select
Rows("1:1").Select
Selection.Copy
Sheets("Open Items").Select
Range("AI1").Select
Selection.End(xlToLeft).Select
ActiveSheet.Paste
Range("A1").Select
MsgBox "Open Items Extracted"
Application.ScreenUpdating = True
End Sub
I want all open items with dates passed by to populate in the Open Item worksheet
This line here Rows(i).Copy Sheets("Open items").Rows(Lastrow) will always paste to the same row because you never increment lastrow. So as your code loops through the sheet the output is constantly being overwritten until the last match is made which is the only one you will see.
Rows(i).Copy Sheets("Open items").Rows(Lastrow)
lastrow = lastrow + 1
I don't think you need i = i + 1 either because your for loop is already incrementing i so you are skipping a line every time it gets there.
EDIT:
Here is what I came up with.
Sub OpenItems()
Dim i As Long
Dim lastrow As Long
Dim lastcol As Long
Dim pasteiter As Long
Application.ScreenUpdating = False
With Sheets("Open Items")
'This will clear the contents of Open Items
lastrow = .Cells(Rows.Count, 43).End(xlUp).Row
lastcol = .Cells.Find(What:="*", after:=ActiveSheet.Cells(1, 1), LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
.Range(.Cells(2, 1), .Cells(lastrow, lastcol)).ClearContents
End With
pasteiter = 2 'Make sure we don't overwrite anything
With Sheets("Observation Tracker")
lastrow = .Cells(Rows.Count, "AQ").End(xlUp).Row
For i = 2 To lastrow
'Combined the two IF statements since we weren't using the outer else.
If (.Cells(i, 28).Value = "Open") And (.Cells(i, 43).Value <= .Cells(i, 46).Value) Then
.Rows(i).Copy Sheets("Open Items").Rows(pasteiter)
pasteiter = pasteiter + 1
End If
Next
.Rows(1).Copy Sheets("Open Items").Rows(1) 'Grab the headers
End With
Application.ScreenUpdating = True
MsgBox "Open Items Extracted"
'I'm not sure what your last bits of code did I removed them.
End Sub
If open items sheet is blank just put something in the first row the first time you run this otherwise you will get a with/object error. Should only occur the first time though.
I removed all your selections and activates, they aren't necessary, slow things down, and obfuscate your code. I also removed lastrowa as it didn't appear to be used.
My code is supposed to select all of the items in A-H from the top of the sheet to the bottom most row containing text in the J column. However, now all it does is select the top row. This code has worked fine elsewhere for other purposes, but when I run it here it only selects the top row.
Here is the code and what it currently does. The commented out bit does the same when it is ran in the place of the other finalrow =statement.
Option Explicit
Sub FindRow()
Dim reportsheet As Worksheet
Dim finalrow As Integer
Set reportsheet = Sheet29
Sheet29.Activate
'finalrow = Cells(Rows.Count, 10).End(xlUp).Row
finalrow = Range("J1048576").End(xlUp).Row
If Not IsEmpty(Sheet29.Range("B2").Value) Then
Range(Cells(1, 1), Cells(finalrow, 8)).Select
End If
End Sub
This is the excerpt of code with a row counter that works.
datasheet.Select
finalrow = Cells(Rows.Count, 1).End(xlUp).Row
''loop through the rows to find the matching records
For i = 1 To finalrow
If Cells(i, 1) = item_code Then ''if the name in H1 matches the search name then
Range(Cells(i, 1), Cells(i, 9)).Copy ''copy columns 1 to 9 (A to I)
reportsheet.Select ''go to the report sheet
Range("A200").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False ''find the first blank and paste info there
datasheet.Select ''go back to the data sheet and continue searching
End If
Next i
You can try this:
Option Explicit
Sub FindRow()
' always use Longs over Integers
Dim finalrow As Long: finalrow = 1
' you might not need this line tbh
Sheet29.Activate
With Sheet29
' custom find last row
Do While True
finalrow = finalrow + 1
If Len(CStr(.Range("J" & finalrow).Value)) = 0 Then Exit Do
Loop
' Len() is sometimes better then IsEmpty()
If Len(CStr(.Range("B2").Value)) > 0 Then
.Range(.Cells(1, 1), .Cells((finalrow - 1), 8)).Select
End If
End With
End Sub
I'm trying to create a vba that copy the cell that match my condition and paste it to another sheet but my problem is it copy all rows with that matched with what I am looking for. I only need to copy the cell that matched. Here is my code
Sub format()
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Cells(i, 1).Value Like "*application_id*" Then
Worksheets("Sheet1").Cell(i).Copy
Worksheets("Sheet2").Activate
b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet2").Cells(b + 1, 1).Select
ActiveSheet.Paste
Worksheets("Sheet1").Activate
End If
Next
End Sub
For the beginning you should avoid all those activate stuff.
I gets a little confusing
I think your problem lies in: Worksheets("Sheet1").Rows(i).Copy
Sub format()
a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To a
If Worksheets("Sheet1").Rows(i, lColumn).Value Like "*application_id*" Then
Temp = Sheets("Sheet1").Cells(i,lColumn).value
b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Sheets("Sheet2").Cells(b + 1, 1) = Temp
End If
Next i
End Sub