How to fix Compile Error: Sub or function not defined in VBA? - vba

This is a code that goes through the cells in column B in sheet2. If it finds a value that is not a date in column B, then it copies it, pastes it another sheet called 'errors' and then deletes that row from Sheet2. Whenever I try to run this, however, I get a 'Compile Error: Sub or function not defined'. I saw some other posts on this, but nothing mentioned there seemed to work for me.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheet("Errors").CountA("A1:A100")
For Each i In Worksheet("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheet("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub

There are a few other errors/changes that could be made within the script
Add s to Worksheet
Use Option Explicit at top of code
Application.WorksheetFunction.CountA
Add range as argument to Counta i.e. Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Ensure correct ranges being worked with by wrapping in With Worksheets("Sheet2")
Determine last row by coming up from bottom of sheet with .Cells(.Rows.Count, "A").End(xlUp).Row, or you could end up looping to bottom of sheet
Correct syntax for delete line: i.EntireRow.Delete
You can put copy paste on one line: .Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
Be wary of using End(xlToRight) in cases of potentially ending up at far right of sheet.
Optimize code by switching some things off e.g. prevent repaint by switching off screen-updating during looping
Gather ranges to delete with Union and delete in 1 go or loop backwards to delete
VBA:
Option Explicit
Public Sub removeerrors()
Dim i As Range, x As Double, loopRange As Range, lastRow As Long, unionRng As Range
x = Application.WorksheetFunction.CountA(Worksheets("Errors").Range("A1:A100"))
Application.ScreenUpdating = False
With Worksheets("Sheet2")
lastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Set loopRange = .Range("A2:A" & lastRow)
If lastRow = 1 Then Exit Sub
For Each i In loopRange
If Not IsDate(i.Offset(0, 1)) Then
.Range(i, i.End(xlToRight)).Copy Worksheets("Errors").Range("A1").Offset(x, 0)
If Not unionRng Is Nothing Then
Set unionRng = Union(unionRng, i)
Else
Set unionRng = i
End If
End If
Next i
End With
If Not unionRng Is Nothing Then unionRng.EntireRow.Delete
Application.ScreenUpdating = True
End Sub

You just need to change Worksheet to Worksheets with 's' at the end.
Sub removeerrors()
Dim i As Range
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
For Each i In Worksheets("Sheet2").Range(Range("A2"), Range("A2").End(xlDown))
If IsDate(i.Offset(0, 1)) = False Then
Range(i, i.End(xlToRight)).Copy
Worksheets("Errors").Range("A1").Offset(x, 0).Paste
Range(i).EntireRow.Delete
End If
Next i
End Sub

use fully qualified range references
loop backwards when deleting rows
update target sheet pasting row index
as follows
Option Explicit
Sub removeerrors()
Dim iRow As Long
Dim x As Double
x = Worksheets("Errors").CountA("A1:A100")
With Worksheets("Sheet2") ' referecne "Sheet2" sheet
With .Range(.Range("A2"), .Range("A2").End(xlDown)) ' reference referenced sheet range from cell A2 down to next not empty one
For iRow = .Rows.Count To 1 Step -1 ' loop reference range backwards from its last row up
If Not IsDate(.Cells(iRow, 2)) Then ' if referenced range cell in column B current row is not a date
.Range(.Cells(iRow, 1), .Cells(iRow, 1).End(xlToRight)).Copy Destination:=Worksheets("Errors").Range("A1").Offset(x, 0) ' copy referenced range current row spanning from column A to next not empty column and paste it to sheet "Errors" column A row x
x = x + 1 ' update offset
.Rows(1).EntireRow.Delete ' delete referenced range current row
End If
Next
End With
End With
End Sub

Related

need vba macro to delete cells except first and last row in each column

I have a excel which has multiple rows and columns and range of column values differ for each row.
Need a macro which will delete all cells in a row except first and last in each row and paste the last value next to first value.
Tried the below script:
Sub test()
Dim sh As Worksheet
Dim IDS As range
Dim ID As range
Set sh = ThisWorkbook.Sheets("Sheet1")
Set IDS = ActiveSheet.range("A2", range("A1").End(xlDown))
For Each ID In IDS
Dim b As Integer
Dim k As Integer
k = sh.range("ID", sh.range("ID").End(xlToRight)).Columns.Count
b = k - 1
range(ID.Offset(0, 0), ID.Offset(0, "b")).Select
Selection.ClearContents
Next ID
End Sub
This is a little different approach but should help.
Also, it is generally not best to declare variables in a loop as you do with b & k just fyi
Sub test()
Dim sh As Worksheet
Dim row As Integer
Dim lastCol As Integer
Set sh = ThisWorkbook.Sheets("Sheet1")
For row = 2 To sh.Cells(Sheets(1).Rows.Count, "A").End(xlUp).row
lastCol = sh.Cells(row, Columns.Count).End(xlToLeft).Column
sh.Range("B" & row).Value = sh.Cells(row, lastCol).Value
sh.Range(sh.Cells(row, 3), sh.Cells(row, lastCol)).ClearContents
Next
End Sub
Best of luck
I'd go as follows:
Sub test()
Dim cell As Range
With ThisWorkbook.Sheets("Sheet1") ' reference relevant sheet
For Each cell In .Range("A2", .Cells(.Rows.Count, "A").End(xlUp)) ' loop through referenced sheet column A cells from row 2 down to last not empty one
With .Range(cell, .Cells(cell.Row, .Columns.Count).End(xlToLeft)) ' reference referenced sheet range spanning from current cell to last not empty one in the same row
If .Count > 2 Then ' if referenced range has more then 2 cells
cell.Offset(, 1).Value = .Cells(1, .Count).Value ' store last cell value next to the current one
.Offset(, 2).Resize(, .Columns.Count - 1).ClearContents 'clear all cells right of current one
End If
End With
Next
End With
End Sub
You can use Range.Delete Method (Excel)
range(ID.Offset(0, 0), ID.Offset(0, b)).Delete Shift:=xlToLeft

Delete entire rows in excel sheet from a table using macro

i want to build a macro that delete rows from a table in an excel sheet based on an if statement that runs on all the rows from row number 2 to the end of the table - if the value in row i and column B equals 0 i would like to delete the entire row.
this is the code i wrote but nothing happens when i run it
Sub deleteZeroRows()
'loop for deleting zero rows
Dim wbCurrent As Workbook
Dim wsCurrent As Worksheet
Dim nLastCol, i As Integer
Set wbCurrent = ActiveWorkbook
Set wsCurrent = wbCurrent.ActiveSheet
Dim lastRow As Long
lastRow = Range("b2").End(xlDown).Select
For i = 2 To lastRow
If wsCurrent.Cells(i, 2) = 0 Then
wsCurrent.Cells(i, 2).EntireRow.Delete
End If
Next i
End Sub
A faster method to delete multiple rows from your worksheet is to store all the Rows that need to be deleted in a Range, using the Union function.
After you exit your For loop, just delete the entire rows DelRng at one command.
More notes in my code's comments below.
Code
Option Explicit '<-- always use this at the top of your code
Sub deleteZeroRows()
Dim wbCurrent As Workbook
Dim wsCurrent As Worksheet
Dim lastRow As Long, nLastCol As Long, i As Long
Dim DelRng As Range
Set wbCurrent = ActiveWorkbook '<-- try to avoid using Active...
Set wsCurrent = wbCurrent.ActiveSheet '<-- try to avoid using Active...
With wsCurrent
lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row ' get last row in column B
For i = 2 To lastRow
If .Range("B" & i).Value = 0 Then
If Not DelRng Is Nothing Then
' add another row to DelRng range
Set DelRng = Application.Union(DelRng, .Rows(i))
Else
Set DelRng = .Rows(i)
End If
End If
Next i
End With
' if there's at least 1 row to be deleted >> delete all rows in DelRng at 1-line
If Not DelRng Is Nothing Then DelRng.Delete
End Sub
a "fast & furious" code:
Sub deleteZeroRows()
With Range("B2", Cells(Rows.Count, 2).End(xlUp)) 'reference column B cells from row 2 down to last not empty one
.Replace what:=0, lookat:=xlWhole, replacement:="" ' replace 0's with blanks
If WorksheetFunction.CountBlank(.Cells) > 0 Then .SpecialCells(XlCellType.xlCellTypeBlanks).EntireRow.Delete ' delete rows where referenced range is blank
End With
End Sub
which will also delete rows whose column B content is blank

How can I write a Macro to sum a Column that has #N/A values in it?

I am looking to create a macro that sums a column that will always contain a few #N/A values, the number of cells in the column will change daily and so will the position of the #N/A values.
I also want to put the result in the first empty cell below that last value i.e. the first empty cell at the bottom of the column.
This is as far as I could get:
Option Explicit
Sub Total()
'
' Total Macro
Dim rg As Range
Dim Cell As Range, Target As Range
Set Target = Range("D65536").End(xlUp)
For Each Cell In Target
Cell.Errors(xlEvaluateToError).Ignore = True
Set rg = Range("D65536").End(xlUp)
rg.Offset(1, 0).Value = "=sumif(D1:D100 " <> 0 & rg.Row & ")"
Range("D65536").End(xlUp).Select
Selection.Font.Bold = True
Next
End Sub
Im using D1:D100 but only because 100 will cover the amount of cells in my Column. This is giving a strange result of more #N/As followed by a True. I dont think I should be trying to use a formula within the code.
Thanks
I would loop through and check if the value is numeric then add it to the total:
Sub mysum()
Dim lstRow As Long
Dim ws As Worksheet
Dim i As Long
Set ws = Worksheets("Sheet5") 'Change to your sheet
With ws
lstRow = .Cells(.Rows.Count, 4).End(xlUp).Row
For i = 1 To lstRow
If IsNumeric(.Cells(i, 4)) Then
.Cells(lstRow + 1, 4) = .Cells(lstRow + 1, 4) + .Cells(i, 4)
End If
Next i
End With
End Sub
You could use SpecialCells():
Sub total()
With Worksheets("SheetName") '<--| Change to your actual sheet name
With .Range("D1", .Cells(.Rows.Count, 4).End(xlUp))
.Cells(.Rows.Count,1).Offset(1).Value = WorksheetFunction.Sum(.SpecialCells(xlCellTypeConstants, xlNumbers))
End With
End With
End Sub

Excel ListObject Table - Remove filtered / hidden rows from ListObject table

I am banging my head to find a way to delete filtered/hidden rows from a ListObject table.
The filtering is not performed trough the code, it's performed by the user using the table header filters. I want to remove the filtered/hidden rows before unlisting the ListObject Table and perform Subtotal operation. If I don't delete the filtered/hidden rows before unlisting the Table, these rows reappear.
Current Code :
Sub SubTotalParClassification(ReportSheetTitle)
Dim ws As Worksheet
Dim drng As Range
Endcol = ColCalculationEndIndex
Set ws = Sheets(ReportSheetTitle)
'CODE TO REMOVE HIDDEN/FILTERED ROWS
Set lo = ActiveSheet.ListObjects("Entrée")
For i = 1 To lo.ListRows.Count Step 1
If Rows(lo.ListRows(i).Range.Row).Hidden = True Then
lo.ListRows(i).Delete
Next
' convert the table back to a range to be able to build subtotal
ws.ListObjects("Entrée").Unlist
With ws
'Select range to Subtotal
Set drng = .Range(.Cells(REPORTHEADERROW, REPORTSSTARTCOL), .Cells(EndRow, Endcol))
'apply Excel SubTotal function
.Cells.RemoveSubtotal
drng.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(Endcol - 6, Endcol - 5, Endcol - 4, Endcol - 3, Endcol - 2, Endcol - 1)
End With
'Update EndRow
EndRow = ActiveSheet.Cells(Rows.Count, REPORTSSTARTCOL).End(xlUp).Row
End Sub
Unfortunately, the Range.SpecialCells method does not have a specific parameter for xlCellTypeInvisible, only one for xlCellTypeVisible. To collect all of the hidden rows we need to find the compliment of the .DataBodyRange property and the visible rows, not the Intersect. A short UDF can take care of that.
Once a Union of the hidden rows have been established you cannot simply delete the rows; you must cycle through the Range.Areas property. Each area will contain one or more contiguous rows and those can be deleted.
Option Explicit
Sub wqewret()
SubTotalParClassification "Sheet3"
End Sub
Sub SubTotalParClassification(ReportSheetTitle)
Dim a As Long, delrng As Range
With Worksheets(ReportSheetTitle)
With .ListObjects("Entrée")
'get the compliment of databody range and visible cells
Set delrng = complimentRange(.DataBodyRange, .DataBodyRange.SpecialCells(xlCellTypeVisible))
Debug.Print delrng.Address(0, 0)
'got the invisible cells, loop through the areas backwards to delete
For a = delrng.Areas.Count To 1 Step -1
delrng.Areas(a).EntireRow.Delete
Next a
End With
End With
End Sub
Function complimentRange(bdyrng As Range, visrng As Range)
Dim rng As Range, invisrng As Range
For Each rng In bdyrng.Columns(1).Cells
If Intersect(visrng, rng) Is Nothing Then
If invisrng Is Nothing Then
Set invisrng = rng
Else
Set invisrng = Union(invisrng, rng)
End If
End If
Next rng
Set complimentRange = invisrng
End Function
Remember that it is considered 'best practise' to start at the bottom and work towards the top when deleting rows.

Check merged cell and compare adjacent to set unique value from compared cells values

I'm writing a macro in Excel 2010 for a problem that is as follows:
I have two columns, one with a Key string value and one with a uuid. The idea is that every key should have only one uuid but as the table is now, key cell could be merged cells or single cells.
The macro needs to recognize which cells are merged and which are not, so, I have two options:
If cell is merged, check all its adjacent cells, pick first uuid value and copy/paste it to other adjacent cells, that is to say, cell below(Could be with an Offset())
If cell is not merged , but key value is repeated in multiple cells, copy/paste uuid value to adjacent cells.
So basically is to check merged cells MergeArea but I don't know if I need to iterate through its addresses or check cells in the range with an offset of Offset(0,1) or what.
With my code I can know if the cells are merged but now, how con I iterate through it's adjacent cells values?
Code as is now:
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.count).End(xlUp).row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
rng.Select
For Each cell In rng
If cell.MergeCells Then
'Code for merged cells
Else
'Code to use for single cells
End If
Next cell
End With
ExitProgram:
Exit Sub
End Sub
Option Explicit
Sub CopyUUID()
Const UUID As Long = 31 'col AE
Dim lRow As Long, cel As Range, isM As Boolean, copyID As Boolean, kCol As Long
With ActiveSheet
kCol = -25 'col F
lRow = .Cells(.Rows.Count, UUID + kCol).End(xlUp).Row
For Each cel In .Range(.Cells(3, UUID), .Cells(lRow, UUID))
isM = cel.Offset(0, kCol).MergeCells
copyID = isM And Len(cel.Offset(0, kCol)) = 0
copyID = copyID Or (Not isM And cel.Offset(0, kCol) = cel.Offset(-1, kCol))
If copyID Then cel = cel.Offset(-1)
Next
End With
End Sub
Try the following code. Note that this is going to overwrite the current contents of UUID, so make a backup copy before testing. If you don't want the UUID column modified, you can modify this to suit your needs.
Sub CopyUUID()
Dim lRow As Long
Dim rng As Range
Dim c As Range
Dim ws As Worksheet
Dim rMerged As Range
Dim value As Variant
Set ws = Sheets(ActiveSheet.Name)
On Error GoTo ExitProgram 'If an error happens within the execution, skips it and continue in next step
' Application.DisplayAlerts = False 'We can cancel the procedure without errors
With ws
lRow = .Range("F" & .Rows.Count).End(xlUp).Row
Set rng = .Range(.Cells(3, 6), .Cells(lRow, 6))
' rng.Select
For Each c In rng
If c.MergeCells Then
'Code for merged cells
c.Offset(0, 1).Formula = c.MergeArea.Cells(1, 1).Offset(0, 1).Formula
Else
'Code to use for single cells
If c.Formula = c.Offset(-1, 0).Formula Then
c.Offset(0, 1).Formula = c.Offset(-1, 1).Formula
End If
End If
Next c
End With
ExitProgram:
Exit Sub
End Sub
When in a MergedCell, it makes the UUID the same as the UUID of the first cell in the merged area. When not in a MergedCell, it copies UUID from the row above if Key is the same as the row above.
I changed your variable cell to c (I don't like to use variable names that can be confused with built-ins) and commented out a couple of lines.
Hope this helps
I adopt a simple approach to this problem as illustrated through steps taken by me.
sample sheet showing data with merged cells and unmerged cells.
Run the program code to unmerge the cells. Output of the program is appended below.
If this structure of data matches your case then addition of 2 lines of code for column B will leave the data as per following image.
Program code is as follows:
'Without column deletion:
Sub UnMergeRanges()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
End Sub
'With coumn deletion
Sub UnMergeRangesB()
Dim cl As Range
Dim rMerged As Range
Dim v As Variant
For Each cl In ActiveSheet.UsedRange
If cl.MergeCells Then
Set rMerged = cl.MergeArea
v = rMerged.Cells(1, 1)
rMerged.MergeCells = False
rMerged = v
End If
Next
Columns("B:B").Select
Selection.Delete Shift:=xlToLeft
End Sub