I want to clear the whole cell including formulas from the last blank cell. Here is what i'm trying to work with but its not working. Would other code affect it? Thanks
Dim myLastRow As Long
Dim clearCell As Long
Application.ScreenUpdating = False
' Find last row
myLastRow = Cells(Rows.Count, "C").End(xlUp).Row
' Loop through range
For clearCell = 4 To myLastRow
If Cells(clearCell, "C").Value = "" Then Range(Cells(clearCell, "C"), Cells(clearCell, "C")).Clear
Next clearCell
Application.ScreenUpdating = True
I don't see anything that would cause an error in your code, other than the fact that your references aren't qualified with the sheet that is being used - which means everything will default to operating on ActiveSheet which may not be the sheet you are wanting it to work on.
Assuming the sheet you want to process has a Name of "Stow", the following code should be safer:
Dim myLastRow As Long
Dim clearCell As Long
Application.ScreenUpdating = False
'Use a "With" block to save typing Worksheets("Stow") in lots of places
'(e.g. within the block we can type ".Cells" instead of "Worksheets("Stow").Cells" and
' ".Rows" instead of "Worksheets("Stow").Rows")
With Worksheets("Stow")
' Find last row
myLastRow = .Cells(.Rows.Count, "C").End(xlUp).Row
' Loop through range
For clearCell = 4 To myLastRow
''Clear any cells with a value of ""
'If .Cells(clearCell, "C").Value = "" Then .Cells(clearCell, "C").Clear
'Clear any cells with a value of "-"
If .Cells(clearCell, "C").Value = "-" Then .Cells(clearCell, "C").Clear
Next clearCell
End With
Application.ScreenUpdating = True
Related
I am trying to wrap my head around a piece of code that has worked for me in the past not working right now in a different application. Basically it needs to delete all rows that contain information in a specific column and leave the rest untouched. When I run the macro the code executes without issues, but just deletes some of the rows with values, not all of them. When running the code several times in a row it ends up doing what it is intended, but it's really not convenient. Here is the code:
Sub Delete_Signoffed()
Dim rCell As Range
Dim iCol As Integer
Dim iRow As Integer
Worksheets("MilestoneDueDate").Activate
If ActiveSheet.AutoFilterMode Then Cells.AutoFilter
ActiveWindow.FreezePanes = False
Columns.EntireColumn.Hidden = False
If WorksheetFunction.CountA(Columns("A")) = 0 Then
Columns("A").Delete
Rows("1:6").Delete
End If
iCol = Cells.Find("Sign-Off By", LookAt:=xlWhole).Column
For iRow = 2 To Cells(Rows.Count, iCol).End(xlUp).Row
Cells(iRow, iCol).Select
If Not IsEmpty(Cells(iRow, iCol).Value) Then Rows(iRow).EntireRow.Delete
Next iRow
End Sub
The source file has some formatting issues, everything that comes before assigning iCol the column value is to fix the format, so please ignore. iRow starts at 2 to avoid deleting the file headers.
Any ideas on why the For loop is not working as intended?
Thanks in advance!
I updated your script. I also added comments for you to be able to understand it better and able to improve it in the future.
Sub Delete_Signoffed()
'Goto CleanUp if there are errors
On Error GoTo CleanUp
Dim wsMilestoneDueDate As Worksheet
Dim rCell As Range
Dim iCol As Integer
Dim iRow As Integer
Set wsMilestoneDueDate = ActiveWorkbook.Worksheets("MilestoneDueDate")
'Disable temporarily Screen Updating
Application.ScreenUpdating = False
With wsMilestoneDueDate
.Activate 'No need, but if you prefer you can
'Activate Auto Filter
If .AutoFilterMode Then Cells.AutoFilter
'Remove FreezePanes
ActiveWindow.FreezePanes = False
'Unhide Columns
.Columns.EntireColumn.Hidden = False
'Delete Empty Columns/Rows if they are all empty
If WorksheetFunction.CountA(.Columns("A")) = 0 Then
Columns("A").Delete
Rows("1:6").Delete
End If
'Get the last Column
iCol = .UsedRange.Find("Sign-Off By", LookAt:=xlWhole).Column
'Start Deleting but from the last to the first (Backward)
For iRow = Cells(Rows.Count, iCol).End(xlUp).Row To 2 Step -1
Set rCell = Cells(iRow, iCol)
'Delete the entire row if it is NOT empty
If Not IsEmpty(rCell.Value) Then
'Deletion
Rows(iRow).EntireRow.Delete
End If
Next iRow
End With
CleanUp:
'Purge Memory
Set wsMilestoneDueDate = Nothing
Set rCell = Nothing
'Restore Screen Updating
Application.ScreenUpdating = True
End Sub
As already stated in comments, the flaw in your code was not looping backwards
But I hereby give you a solution without looping and using one line only, thanks to SpecialCells method of Range object, specifying it to filter cells with some "constant" (i.e. not deriving from formulas) value
Range(Cells(2, iCol), Cells(Rows.Count, iCol).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
this assumes you always have at least one value below row 1
should not that be the case then just add a check:
If Cells(Rows.Count, iCol).End(xlUp).Row > 1 Then Range(Cells(2, iCol), Cells(Rows.Count, iCol).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
While looking at your entire code you should adopt the good practice to avoid Select/Selection, Activate/ActiveXXX pattern and Always fully qualify ranges up to their worksheet (if not workbook) parent objects, like follows:
Sub Delete_Signoffed()
Dim iCol As Long
With Worksheets("MilestoneDueDate") ' reference wanted sheet
If .AutoFilterMode Then .Cells.AutoFilter
ActiveWindow.FreezePanes = False
.Columns.EntireColumn.Hidden = False
If WorksheetFunction.CountA(.Columns("A")) = 0 Then
.Columns("A").Delete
.Rows("1:6").Delete
End If
iCol = .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).Find("Sign-Off By", LookAt:=xlWhole, LookIn:=xlValues).Column
.Range(.Cells(2, iCol), .Cells(.Rows.Count, iCol).End(xlUp)).SpecialCells(xlCellTypeConstants).EntireRow.Delete
End With
End Sub
as you can see
all range objects (Columns(), Rows, Range, Cells) are referencing Worksheets("MilestoneDueDate") through that dot (.) in front of them
iCol is being set running Find() method in the most restricted range possibile
I'm looking for a VBA code to as the title specifies, delete data based on conditions
So I have Column A and Column B, Rows starts from 2 until the end of the sheet, so as an example If the value in B2 is "OK", I would like for the value in A2 to be cleared and then loop the same process until the end of both columns, this is what I have so far but it's not working properly:
Sub Clear()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
Find last row
myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
Loop through range
For i = 2 To myLastRow
If Cells(i, "B").Value = "OK" Then Range(Cells(i, "A")).ClearContents
Next i
Application.ScreenUpdating = True
End Sub
Quick fix for your code is to remove Range
Sub Clear()
Dim myLastRow As Long
Dim i As Long
Application.ScreenUpdating = False
'Find last row
myLastRow = Cells(Rows.Count, "B").End(xlUp).Row
' Loop through range
For i = 2 To myLastRow
' If Cells(i, "B").Value = "OK" Then Range(Cells(i, "A")).ClearContents
If Cells(i, "B").Value = "OK" Then Cells(i, "A").ClearContents
Next i
Application.ScreenUpdating = True
End Sub
Pay attention as Cells refers to the active sheet. In case you would like to run the code on a specific sheet you should better specifiy the sheet.
I am working on a Macro that will copy every other value in a column of data and paste continuously to a new column in a new sheet. In my code below, the For i = 4 To LastRowC Step 2 loop is working, as it works out that the first empty row to paste is in the right spot.
However, for the For i = 4 To LastRowC Step 2 loop, the macro is finding a row too far down, as there is another filled row throwing it off, and I need to designate it to start pasting higher up at a specific cell. But it still needs to look for empty rows for pasting after for the duration of the for loop. Is this possible?
Option Explicit
Sub copyRange()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim wkbDest As Workbook
Dim wkbSource As Workbook
Set wkbDest = ThisWorkbook
Dim strExtension As String
Dim LastRowC As Long
Const strPath As String = "C:\Users\NGiuliano\Desktop\UPLOADS2\"
ChDir strPath
strExtension = Dir(strPath & "*.xls*")
Do While strExtension <> ""
Set wkbSource = Workbooks.Open(strPath & strExtension)
With wkbSource.Sheets("Sheet1")
LastRowC = wkbSource.Worksheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row
For i = 4 To LastRowC Step 2
wkbSource.Worksheets("Sheet1").Range("A" & i).Copy
wkbDest.Worksheets("WIP").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next i
For j = 4 To LastRowC Step 2
wkbSource.Worksheets("Sheet1").Range("B" & j).Copy
wkbDest.Worksheets("WIP").Cells(Rows.Count, 16).End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next j
Application.CutCopyMode = False
End With
wkbSource.Close savechanges:=False
strExtension = Dir
Loop
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Will build on the code I provided in the last question:
Dim nextrow as Long 'Option 1; this dimension isn't appropriate for Option 2
nextrow = 2 'starting row for pasting, used for Option 1
For i = 4 to LastRowC Step 2
'Use Cells(i,"B") or Range("B" & i)
'Option 1, use a counter (declare "nextrow" as Long and define before the loop, e.g., 2)
wkbDest.Worksheets("WIP").Cells(nextrow,16).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
nextrow = nextrow + 1
'Option 2, find next cell each time using "end(xldown)"
set nextcell = wkbDest.Worksheets("WIP").Cells(2,16).End(xlDown).Offset(1)
nextcell.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
Next i
You can use either option, where nextrow is the row number and nextcell is the actual next cell that would be used.
In your code you're attempting to use a standard lastrow syntax (.End(xlUp)), which is great if needed... are you familiar with how that script actually works?
With Workbooks("Name").Sheets("Name")
lastrow = .Cells(.Rows.Count, 1).End(xlUp).Row 'Option 1
set nextcell = .Cells(.Rows.Count, 1).End(xlUp) 'Option 2
End With
In order it goes:
Find the workbook
Find the worksheet
Find the cell
Column found
Count of ALL rows in column found (i.e., 1,048,576)
From the last counted row go xlUp to the next cell with data
Now, you can either set that as a range, or you can .row/.column to find the parameter you want. In your example you did neither, and actually have inappropriate syntax in your .pastespecial line.
Spend some time to read up on the functionality of each line in your code and that might help move you forward!
I run my VBA code and the first time it runs I get the result I want but if I run it a second time my column headers get deleted. FYI my table starts on E and goes through N. My button is on column O and also gets deleted when I run it a second time.
Switching the Range did not help and setting AutoFilter to false also did not work.
#
Sub Auto_filter()
Dim sh As Worksheet
Set sh = ThisWorkbook.Worksheets("HP Service Manager")
sh.AutoFilterMode = False
With sh
On Error Resume Next
.ShowAllData
.Range("E1:N1").AutoFilter 1, "IM*"
AutoFilter = False
End With
End Sub
#
Expect to not have column headers deleted.
The issue is in the second code you shared.
The code is first setting the range here:
Set Rng = Range("E1", Cells(iRow, "E"))
And then here it is trying to delete all visible cells in the range (after applying the filter)
Rng.SpecialCells(xlCellTypeVisible).EntireRow.Delete
which also includes your header cell.
So, a simple way to deal with it could be to set another range like this
Set Rng2 = Range("E2", Cells(iRow, "E"))
and then using it to delete the data
Rng2.SpecialCells(xlCellTypeVisible).EntireRow.Delete
Here is the re-written function for your reference. This only deletes the rows starting from row 2 that are blank. You may want to add some error handing in case there are no blank rows to delete etc.
Sub DeleteRowsAll()
Dim iRow As Long
Dim Rng As Range
Application.ScreenUpdating = False
Rows(1).Insert
Range("E1").Value = "rabbitohs"
With ActiveSheet
.UsedRange
iRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
Set Rng = Range("E1", Cells(iRow, "E"))
Rng.AutoFilter Field:=1, Criteria1:=""
Set Rng2 = Range("E2", Cells(iRow, "E"))
Rng2.SpecialCells(xlCellTypeVisible).EntireRow.Delete
.UsedRange
End With
End Sub
Sub DeleteRowsAll()
Dim LastRow As Long
Dim CellValue As String
LastRow = Worksheets("HP Service Manager").Cells(Rows.Count, "E").End(xlUp).Row
For i = LastRow To 2 Step -1
CellValue = Worksheets("HP Service Manager").Cells(i, "E").Value
If CellValue = "" Then
Worksheets("HP Service Manager").Rows(i).Delete
End If
Next i
End Sub
I'm trying to create a macro that would search the value of the cell B5 in a sheet called DB and paste all of the results in a sheet called Research. The idea is to copy every line that match the keyword and to paste them starting at B11 in the DB sheet.
I don't know if it's possible, but thank you in advance for your time.
Sub CreateList()
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim LastRow As Long
Dim I As Integer
Dim J As Integer
Dim srchtxt As String
Dim celltxt As String
'Determines last row of database worksheet to know what range to loop through
LastRow = Worksheets("DB").Cells.Find(What:="*", After:=Range("A1"), SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
'Gets the text or value to be searched
srchtxt = Worksheets("SearchWS").Range("B5") '***Change cell to search
'Clear research sheet, the destination sheet
Worksheets("Research").Cells.Clear
'Activate DataBase sheet
Worksheets("DB").Activate
'Loops through and copies all rows with desired value or text, pasting them in the research sheet. j keeps track of the next empty row.
'The InStr and UCase ensure capitalization doesn't cause a problem. You may not want this if you need exact match.
J = 2 '*** Change the first row to paste
For I = 2 To LastRow
celltxt = Worksheets("DB").Cells(I, 1).Text 'Gets the value from the DB worksheet ***Change the column to seach in
If InStr(1, UCase(celltxt), UCase(srchtxt)) Then 'Compares it to the specified text, B5 in this case
Worksheets("DB").Range(Cells(I, 1), Cells(I, 2)).Copy Destination:=Worksheets("Research").Cells(J, 1)
'Copies the range above. ***Change the range to copy, from 1 to 2
J = J + 1
End If
Next I 'Loops through
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub