I have the following macro that adds 0s to ID numbers until they are 7 numbers long. I have used it countless times before and it has always worked without fail until today it started not working and the portion of the code For i = 1 To endrow - 1 is highlighted every time and I cannot debug the issue. The whole code is.
Sub AddZeroes()
'Declarations
Dim i As Integer, j As Integer, endrow As Long
'Converts the A column format to Text format
Application.ScreenUpdating = False
Columns("A:A").Select
Selection.NumberFormat = "#"
'finds the bottom most row
endrow = ActiveSheet.Range("A1").End(xlDown).Row
'selects the top cell in column A
ActiveSheet.Range("A1").Select
'loop to move from cell to cell
For i = 1 To endrow - 1
'Moves the cell down 1. Assumes there's a header row so really starts at row 2
ActiveCell.Offset(1, 0).Select
'The Do-While loop keeps adding zeroes to the front of the cell value until it hits a length of 7
Do While Len(ActiveCell.Value) < 7
ActiveCell.Value = "0" & ActiveCell.Value
Loop
Next i
Application.ScreenUpdating = True
End Sub
Not sure what is causing the error - but would suggest another approach:
sub addZeros()
Application.ScreenUpdating = False
' start at row 2 since OP said there's a header row
Dim c as Range
for each c in Range("A2", [A2].End(xlDown))
c.Value = "'" & Format(c.Value, "00000000")
next c
Application.ScreenUpdating = True
end sub
A bit more compact...
Note that I'm adding the "'" apostrophe to make Excel treat the cell value as string. This is a safe way to make sure the zeros stay...
EDIT: Got rid of the last .Select to show it can be done, and is generally good practice as pointed out in comments.
Related
I have what I thought would be a simple script, but I have some some strange results.
Goal: Identify specific IDs in a SOURCE sheet using a list of IDs on a Translator Sheet. When found, copy the entire row to and OUTPUT sheet.
The output has strange results that I can't figure out.
Returns all results instead of the limited list. AND results are in weird groupings. (First result is on row 21 and only has 9 rows of data, the next group has 90 rows of data, starting on row 210, then blank rows, then 900 rows of data, etc.
Results do not start in row 2.
Full code is below attempts:
Attempts:
I first searched the SOURCE sheet based on one ID that was hard coded as a simple test and it worked. but when I changed the code to search a range (z21:z), two things happened: 1, it returns everything in the Source file in multiples of 9 as stated above, AND as you can imagine, the time to complete skyrocketed from seconds to minutes. I think I missed a add'l section of code to identify the range??
Old Code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("D62D627EB404207DE053D71C880A3E05") Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
New code:
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I)** Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
1a. I believe one issue is that the Translator list has duplicates. Second, it is searching the entire column Z. Second issue may be that The list in Translator is generated via a formula in column Z, thus if the formula is false, it will insert a "" into the cell. I seek the code to NOT paste those rows where the cell content is either a "" or is a true blank cell. Reason: The "" will cause issues when we try to load the Output file into a downstream system because it is not a true blank cell.
Results in wrong location: When the script is complete, my first result does not start on Row 2 as expected. I thought the clear contents would fix this, but maybe a different clear function is required? or the clear function is in the wrong place? Below screenshot shows how it should show up. It is in the same columns but doesn't start until row 21.
enter image description here
Slow code: I have a command that copies and pastes of the first row from SOURCE to OUTPUT. My code is cumbersome. There has to be an easier way. I am doing this copy and paste just in case the source file adds new columns in the future.
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Thank you for all your help.
Option Explicit
Sub MoveRowBasedOnCellValuefromlist()
'Updated by xxx 2023.01.18
Dim xRg As Range
Dim xCell As Range
Dim I As Long
Dim J As Long
Dim K As Long
I = Worksheets("SOURCE").UsedRange.Rows.Count
J = Worksheets("Output").UsedRange.Rows.Count
If J = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Output").UsedRange) = 0 Then J = 0
End If
Worksheets("Output").Cells.ClearContents
Sheets("SOURCE").Select
Rows("1:1").Select
Selection.Copy
Sheets("Output").Select
Rows("1:1").Select
ActiveSheet.Paste
Set xRg = Worksheets("SOURCE").Range("B2:B" & I)
On Error Resume Next
Application.ScreenUpdating = False
'NOTE - There are duplicates in the Translator list. I only want it to paste the first instance.
'Otherwise, I need to create an =Unique() formula and that seems like unnecessary work.
For K = 1 To xRg.Count
If CStr(xRg(K).Value) = Worksheets("Translator").Range("z21:z" & I) Then
xRg(K).EntireRow.Copy Destination:=Worksheets("Output").Range("A2" & J + 1)
J = J + 1
End If
Next
Application.ScreenUpdating = True
End Sub
Try this out - using Match as a fast way to check if a value is contained in your lookup list.
Sub MoveRowBasedOnCellValuefromlist()
Dim c As Range, wsSrc As Worksheet, wsOut As Worksheet, wb As Workbook
Dim cDest As Range, wsTrans As Worksheet, rngList As Range
Set wb = ThisWorkbook 'for example
Set wsSrc = wb.Worksheets("SOURCE")
Set wsOut = wb.Worksheets("Output")
Set wsTrans = wb.Worksheets("Translator")
Set rngList = wsTrans.Range("Z21:Z" & wsTrans.Cells(Rows.Count, "Z").End(xlUp).Row)
ClearSheet wsOut
wsSrc.Rows(1).Copy wsOut.Rows(1)
Set cDest = wsOut.Range("A2") 'first paste destination
Application.ScreenUpdating = False
For Each c In wsSrc.Range("B2:B" & wsSrc.Cells(Rows.Count, "B").End(xlUp).Row).Cells
If Not IsError(Application.Match(c.Value, rngList, 0)) Then 'any match in lookup list?
c.EntireRow.Copy cDest
Set cDest = cDest.Offset(1) 'next paste row
End If
Next c
Application.ScreenUpdating = True
End Sub
'clear a worksheet
Sub ClearSheet(ws As Worksheet)
With ws.Cells
.ClearContents
.ClearFormats
End With
End Sub
I'm trying to check the contents of the cells in column Q and delete the rows that have a 0 in that column.
The macro should start checking in column Q at cell Q11 and stop when it encounters the cell containing the text "END". When finished it should select the cell at the upper left corner of the spreadsheet, which would normally be A1, but I have a merged cell there, so it's A1:K2.
Here are my two most recent versions of the macro:
'My second to last attempt
Sub DeleteRowMacro1()
Dim i As Integer
i = 11
Do
Cells(i, 17).Activate
If ActiveCell.Value = 0 Then
ActiveCell.EntireRow.Delete
End If
i = i + 1
Loop Until ActiveCell.Value = "END"
Range("A1:K2").Select
End Sub
'My last attempt
Sub DeleteRowMacro2()
Dim i As Integer
i = 11
GoTo Filter
Filter:
Cells(i, 17).Activate
If ActiveCell.Value = "END" Then GoTo EndingCondition
If ActiveCell.Value = "" Then GoTo KeepCondition
If ActiveCell.Value = 0 Then GoTo DeleteCondition
If ActiveCell.Value > 0 Then GoTo KeepCondition
EndingCondition:
Range("A1:K2").Select
KeepCondition:
i = i + 1
GoTo Filter
DeleteCondition:
ActiveCell.EntireRow.Delete
i = i + 1
GoTo Filter
End Sub
What DeleteRowMacro1() Does:
It leaves the row if there is text or a number greater than 0 in column Q, but it deletes the rows with cells with a 0 AND blank cells. I want to keep the rows with the blank cells.
This macro seems to be incapable of checking the 450 or so cells between the Q11 and the cell with "END" in one run. It only deletes about half of the rows it should each time. The first 10 or so rows are always done correctly, but then it appears to randomly choose rows with a zero or a blank in column Q to delete.
If I run the macro 7 or 8 times, it will eventually delete all of the rows with a 0 and the ones that are blank too. I would like it to completely do it's job in one run and not delete the rows with blank cells.
What DeleteRowMacro2() Does:
It never stops at "END".
I have to run it 7 or 8 times to completely get rid of all of the rows with a 0 in column Q. It also appears to randomly check cells for deletion (and once again besides the first 10 or so).
Because it never ends when I run it, the area of my screen where the spreadsheet is turns black and all I can see there is the green selected cell box flickering up and down at random locations in the Q column until it gets to a row number in the 32,000s. After that my screen returns to show the normal white spreadsheet and a box appears that says Run-time error '6': Overflow.
Please note: After I click "End" on the error box I can see that the macro worked as described above.
Try it as,
Option Explicit
Sub DeleteRowMacro3()
Dim rwend As Variant
With Worksheets("Sheet5")
If .AutoFilterMode Then .AutoFilterMode = False
rwend = Application.Match("end", .Range(.Cells(11, "Q"), .Cells(.Rows.Count, "Q")), 0)
If Not IsError(rwend) Then
With .Range(.Cells(10, "Q"), .Cells(rwend + 10, "Q"))
.AutoFilter Field:=1, Criteria1:=0, Operator:=xlOr, Criteria2:=vbNullString
With .Resize(.Rows.Count - 1, 1).Offset(1, 0)
If CBool(Application.Subtotal(103, .Cells)) Then
.SpecialCells(xlCellTypeVisible).EntireRow.Delete
End If
End With
End With
End If
.Activate
.Range("A1:K2").Select
If .AutoFilterMode Then .AutoFilterMode = False
End With
End Sub
I wasn't sure if you were looking specifically for zeroes or zero value so I included blank cells as well as numerical zeroes.
First, it's best practice to avoid using .Select/.Activate. That can cause some confusion and tricky writing when doing loops/macros in general.
Second, it's also best to avoid GoTo.
This macro will start at the last row in column Q, and make its way toward row 11. If the value of a cell is 0, it'll delete the row. If the value is END, it selects your range and exits the For loop, and then exits the sub.
Sub delRows()
Dim lastRow As Long, i As Long
Dim ws as Worksheet
Set ws = Worksheets("Sheet1") ' CHANGE THIS AS NECESSARY
lastRow = ws.Cells(ws.Rows.Count, 17).End(xlUp).Row
For i = lastRow To 11 Step -1
If ws.Cells(i, 17).Value = "END" Then
ws.Range("A1:K2").Select
Exit For
End If
If ws.Cells(i, 17).Value = 0 or ws.Cells(i, 17).Value = "0" Then
ws.Cells(i, 17).EntireRow.Delete
End If
Next i
End Sub
Try this variation of your first code:
Sub DeleteRowMacro1()
Dim i As Integer
i = 11
Do
Cells(i, 17).Activate
If IsEmpty(ActiveCell.Value) Then
ActiveCell.EntireRow.Delete
End If
If ActiveCell.Value = "END" Then
Exit Do
End If
i = i + 1
Loop
Range("A1:K2").Select
End Sub
Try this simpler, and faster version. It will locate all of the cells you want to delete, store them in a range object, and then delete them all at once at the end.
Public Sub DeleteRowsWithRange()
Dim rngLoop As Range
Dim rngMyRange As Range
For Each rngLoop In Columns("Q").Cells
If rngLoop.Value = "END" Then
Exit For
ElseIf rngLoop.Value = 0 Then
If rngMyRange Is Nothing Then
Set rngMyRange = rngLoop.EntireRow
Else
Set rngMyRange = Union(rngMyRange, rngLoop.EntireRow)
End If
End If
Next rngLoop
If Not rngMyRange Is Nothing Then rngMyRange.Delete xlShiftUp
Range("A1").Activate
Set rngLoop = Nothing
Set rngMyRange = Nothing
End Sub
Im trying to write / find a macro that when ran removes the value in a cell if the cells in the column is not a number. IE remove all the cells in column B if a string is found. I have this script to delete empty rows.
Was just trying to re write it so that it can delete the rows based on these condiitions
Sub RemoveRows()
Dim lastrow As Long
Dim ISEmpty As Long
lastrow = Application.CountA(Range("A:XFD"))
Range("A1").Select
Do While ActiveCell.Row < lastrow
ISEmpty = Application.CountA(ActiveCell.EntireRow)
If ISEmpty = 0 Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
Loop
End Sub
The code iterates backward from the last cell in column B and checks if the value in the cell is numeric using the IsNumeric() function.
If the value is not numeric then it deletes the entire row.
Note: looping backwards (ie. from the last row to first) is necessary when using a loop because the index gets shifted everytime a row gets deleted. Therefore, to avoid skipping some rows backward iteration is required.
Sub KeepOnlyNumbers()
Application.ScreenUpdating = False
Dim ws As Worksheet
Set ws = Sheets("Sheet1")
Dim i As Long
' iterating backwards (from last row to first to keep the logic flow)
For i = ws.Range("B" & ws.Rows.Count).End(xlUp).Row To 1 Step -1
' check whether the value is numeric
If Not IsNumeric(Range("B" & i)) Then
' if not numeric then clear the cells content
Range("B" & i).ClearContents
End If
Next i
Application.ScreenUpdating = True
End Sub
You can use IsNumeric to evaluate if an object can be evaluated as a number. So you can add:
If Not IsNumeric(ActiveCell) Then
ActiveCell.EntireRow.Delete
Else
ActiveCell.Offset(1, 0).Select
End If
to your Do While loop and it should do what you want. I haven't tested this; let me know if you get an error.
You do not have to iterate backwards even when deleting rows, you can do union and call delete/clear on the unioned range.
Sub UnionOnCondition()
Dim usedColumnB
Set usedColumnB = Intersect(ActiveSheet.UsedRange, _
ActiveSheet.Columns("b"))
If usedColumnB Is Nothing Then _
Exit Sub
Dim result: Set result = Nothing
Dim cellObject
For Each cellObject In usedColumnB
' skip blanks, formulas, dates, numbers
If cellObject = "" Or _
cellObject.HasFormula Or _
IsDate(cellObject) Or _
IsNumeric(cellObject) Then GoTo continue
If result Is Nothing Then
Set result = cellObject.EntireRow
Else
Set result = Union(result, cellObject.EntireRow)
End If
continue:
Next
If Not result Is Nothing Then _
result.Select ' result.Clear or result.Delete
End Sub
I have the following code,
Sub AddZeroes()
'Declarations
Dim i As Integer, j As Integer, endrow As Long
'Converts the A column format to Text format
Application.ScreenUpdating = False
Columns("A:A").Select
Selection.NumberFormat = "#"
'finds the bottom most row
endrow = ActiveSheet.Range("A1").End(xlDown).Row
'selects the top cell in column A
ActiveSheet.Range("A1").Select
'loop to move from cell to cell
For i = 1 To endrow - 1
'Moves the cell down 1. Assumes there's a header row so really starts at row 2
ActiveCell.Offset(1, 0).Select
'The Do-While loop keeps adding zeroes to the front of the cell value until it hits a length of 7
Do While Len(ActiveCell.Value) < 7
ActiveCell.Value = "0" & ActiveCell.Value
Loop
Next i
Application.ScreenUpdating = True
End Sub
And it adds preceding zeroes to numbers and converts them to text to make them 7 charecters long if they are less than 7. ANd it has been working all day and suddenly it has stopped. I Keep getting the error RUN TIME ERROR 6 OVERFLOW. I am at a loss because it has worked without any issues all day up until now. It keeps highlighting the portion:
For i = 1 To endrow - 1
Any thoughts?
Change this line:
Dim i As Integer, j As Integer, endrow As Long
To be this instead:
Dim i As Long, j As Long, endrow As Long
Integer variables can only go up to 32,767. If your row numbers are higher than that, you need to use Long.
The code below is working. It will progress through all columns in the sheet and change the data within it to a number of fixed length based on the number found in the 2nd row.
My issue is that it selects the entire column when doing so. This is a problem for me since I have 4 header rows that I do not want converted.
My first thought was to offset/resize a selection and apply changes to all cells, but I'm simply having no luck doing that.
Can anyone modify this code to ignore the first 4 header rows as it progresses through the columns?
Note: lastCol is a separate function that simply returns an integer value with the number of the last used column on the sheet.
Sub FormatFixedNumber()
Dim i As Long
Application.ScreenUpdating = False
For i = 1 To lastCol 'replace 10 by the index of the last column of your spreadsheet
With Columns(i)
.NumberFormat = String(.Cells(2, 1), "0") 'number length is in second row
End With
Next i
Application.ScreenUpdating = True
End Sub
This should do it. I added a Constant to hold the header rows count.
EDIT: Added code to just go to last row as requested. Also checks that LastRow is greater than HEADER_ROWS. And fixed some convoluted adding and subtracting of the HEADER_ROWS in the Resize/Offset.
Sub FormatFixedNumber()
Const HEADER_ROWS As Long = 4
Dim i As Long
Dim LastRow As Long
Application.ScreenUpdating = False
For i = 1 To LastCol 'replace 10 by the index of the last column of your spreadsheet
With Columns(i)
LastRow = .Cells(Rows.Count).End(xlUp).Row
If LastRow > HEADER_ROWS Then
With .Resize(LastRow - HEADER_ROWS).Offset(HEADER_ROWS)
.NumberFormat = String(.EntireColumn.Cells(2, 1), "0") 'number length is in second row
End With
End If
End With
Next i
Application.ScreenUpdating = True
End Sub