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
Related
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
Would like to delete rows from a report based on the data in column M. Report is of variable size row-wise but the same width in columns. "Valid" in a cell means it gets deleted.
Sub Create()
Dim Range1 As Range
Set Range1 = Range("M:M")
For Each cell In Range1
If ActiveCell.Value = "Valid" _
Then ActiveCell.EntireRow.Delete
Next cell
End Sub
It now about the ActiveCell but cells in the column "M:M". Also, you need to start form the bottom up (not obvious but true). So, assuming there are fewer rows than 10000, you need something like this:
Sub Create()
Dim LastRow As Long
Dim i As Long
LastRow = Range("M10000").End(xlUp).Row
For i = LastRow To 1 Step -1
If Range("M" & i) = "Valid" Then
Range("M" & i).EntireRow.Delete
End If
Next
End Sub
I found a way using your For Each :
Public Sub Create()
Dim Range1 As Range
Dim Cell
Dim LastRow As Long
Set Range1 = Range("M1")
' assume, there is some data in the first row of your sheet
LastRow = Range1.CurrentRegion.Rows.Count
' otherwise, find last cell in column M with a value, assume before row 10000
LastRow = Range("M10000").End(xlUp).Row
' select the cells to process
Set Range1 = Range(Range1, Range1.Offset(LastRow, 0))
' process the rows
For Each Cell In Range1
If Cell.Value = "Valid" Then
Debug.Print "' delete row from at address :: " & Cell.Address
Range(Cell.Address).EntireRow.Delete
End If
Next
End Sub
This sounds like a very basic question (and it is), but I cannot figure it out and I cannot find a suitable solution on the web.
How do you select the last cell in a column that contains a numeric value and delete it?
I have formulas that go past this cell and return blank values in the column. This is what is tripping me up at the moment. My current code will go all the way down to where I have carried the formulas to and start deleting those cells instead of deleting the last cell with a numeric value.
My current code looks like this
Range("AA1500").End(xlUp).Select
With Selection.Delete
End With
Any help would be greatly appreciated.
Please let me know if I can clarify anything.
Thanks
If you want to go down past cells with arbitrary strings in them and
delete the last numeric value (but not the last cell with a alphanumeric string in it), this should work:
Sub deleteLastNum()
Dim row As Integer
row = Range("A1000").End(xlUp).row
For i = row To 1 Step -1:
If IsNumeric(Cells(i, "A")) Then
Cells(i, "A").Clear
Range("A" & CStr(i + 1), "A" & CStr(row)).Cut Destination:=Range("A" & CStr(i))
Exit For
End If
Next
End Sub
It will also delete the last cell with a formula that evaluates to a number. It moves down the range of cells in the column above it with characters in it to fill in the cleared cell.
What you can do is get the total number of rows of a column (A) then check is last cell value is numeric or not, if numeric then clear that cell.
Sub del()
Dim sh As Worksheet
Dim rn As Range
Set sh = ThisWorkbook.Sheets("Sheet1")
Dim k As Long
Set rn = sh.UsedRange
k = rn.Rows.Count + rn.Row - 1
If IsNumeric(Sheets("Sheet1").Range("A" & k).Value) = True Then
Sheets("Sheet1").Range("A" & k).ClearContents
End If
End Sub
This will check last cell for numeric value in column A.
Hope this is what you are asking.
EDIT
Implementing above for all the sheets in a workbook using a loop is like :
Sub del()
Dim sh As Worksheet
Dim rn As Range
For Each sh In ActiveWorkbook.Worksheets
Set sh = ThisWorkbook.Sheets(sh.Name)
Dim k As Long
Set rn = sh.UsedRange
k = rn.Rows.Count + rn.Row - 1
If IsNumeric(sh.Range("A" & k).Value) = True Then
sh.Range("A" & k).ClearContents
End If
Next sh
End Sub
This will loop through each sheet like Sheet1, Sheet2 or whatever the name of the sheet may be and check for numeric value in last cell of col A, if found numeric then it will delete the value.
You already got an answer to your post, just to be clear, the safest way to find the last row (let's say in Column "AA", according to your post), and ignoring blank cells in the middle, is by using the syntax below:
Sub FindlastRow()
Dim LastRow As Long
With Worksheets("Sheet1") ' <-- change "Sheet1" to your sheet's name
LastRow = .Cells(.Rows.Count, "AA").End(xlUp).Row
' rest of your coding here
End With
End Sub
Screen-shot of the result:
Use 'SpecialCells()'
Sub ClearLastNumber(sh As WorkSheet, columnIndex As String)
On Error GoTo ExitSub 'should 'columnIndex' column of 'sh' worksheet contain no numbers then the subsequent statement would throw an error
With sh.Columns(columnIndex).SpecialCells(xlCellTypeConstants, xlNumbers)
With .Areas(.Areas.Count)
.Cells(.Count).ClearContents
End With
End With
ExitSub:
End Sub
To be used in your "main" sub as follows
Sub Main()
Dim sh As Worksheet
For Each sh In ActiveWorkbook.Worksheets
ClearLastNumber Sh "A"
Next
End Sub
Problem: Make a loop that creates an array of all cells under a column, for each column on a sheet.
I am trying to make a script that will compare data from a column on one sheet, against multiple columns, until there are no more columns. Once I find a match I report the header to the first sheet, if I don't find a match I report "No Match".
Right now I have the logic to go through one column and report the outcome, but I'm not sure how to create a loop to compares against each consecutive column on the sheet. I have comments where I think I have gone wrong.
Thanks in advance for any dvice or direction.
Thanks,
Example Data:
SHEET1
SHEET2
Sub compareColumns()
Dim a As Long, arrA As Variant, arrB As Variant, dict As Object, c As Long, l As Long, cList As String
Set dict = CreateObject("scripting.Dictionary")
dict.comparemode = vbTextCompare
' Build the dictionary to compare with other columns
With Worksheets("sheet1")
With Intersect(.UsedRange, .Range("A1:A100"))
arrA = .Cells.Value2
End With
For a = LBound(arrA, 1) + 2 To UBound(arrA, 1) 'LBound(arrA, 1)+2 to skip the column header and leave a space to put a result
dict.Item(arrA(a, 1)) = arrA(a, 1)
Next a
End With
cList = ThisWorkbook.Sheets(1).Column.Count
With Worksheets("sheet2")
For l = 0 To cList
With Intersect(.UsedRange, .Cells(1, l)) 'NOT SURE IF THIS WORKS WITH CELLS
arr(l) = .Cells.Value2 ' NOT SURE HOW TO MAKE ARRAYS FROM A LOOP
End With
Next l
End With
' C for compare, check against a column and if not match go to the next column, if match type result
For c = LBound(arrA, 1) + 2 To UBound(arrA, 1) 'LBound(arrA, 1)+2 to skip the column header and leave room for result
If dict.Item(arrA(c, 1)) <> arrB(c - 1, 1) Then 'had to -1 the c to make up for the space that are in the columns
' GO TO THE NEXT COLUMN OR ARRAY CHECK
Exit For
End If
Next c
With Worksheets("sheet1")
.Cells(2, 1).Value = arrB(1, 1) 'UPDATE EACH COLUMN
End With
End Sub
a VBA solution could be the following:
Sub main()
Dim strngToMatch As String
Dim cell As Range
With Worksheets("Sheet1")
strngToMatch = Join(Application.Transpose(.Range("A3", .Cells(.Rows.Count, 1).End(xlUp)).Value), "")
End With
With Worksheets("Sheet2")
For Each cell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).SpecialCells(xlCellTypeConstants)
If strngToMatch = Join(Application.Transpose(.Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp)).Value), "") Then
Worksheets("Sheet01").Range("A2").Value = cell.Value
Exit For
End If
Next cell
End With
End Sub
which can be refactored not to clutter the "main" code as follows:
Sub main()
With Worksheets("Sheet01")
.Range("A2").Value = Join(Application.Transpose(.Range("A3", .Cells(.Rows.Count, 1).End(xlUp)).Value), "")
End With
End Sub
Function GetHeader(shtName As String, strngToMatch As String) As String
Dim cell As Range
With Worksheets(shtName)
For Each cell In .Range("A1", .Cells(1, .Columns.Count).End(xlToLeft)).SpecialCells(xlCellTypeConstants)
If strngToMatch = Join(Application.Transpose(.Range(cell.Offset(1), .Cells(.Rows.Count, cell.Column).End(xlUp)).Value), "") Then
GetHeader = cell.Value
Exit For
End If
Next cell
End With
End Function
where the "main" code is quite ready to host a loop over "FACT" columns
So this is what I did. On the first sheet
On the second sheet
and finally do a match
in the first sheet
=IF( ISNUMBER(MATCH(B3, Sheet2!A2:D2, 0)), "MATCH", "NO MATCH")
I'm fairly new to VBA. I'm currently trying to find a faster way to copy and paste information by using Macros. I'm not sure how to code this.
I have two columns I want to use with a For Each loop.
I wanted to loop through each row of these two columns and use an If function. If the first row has a value in Column B (Column B cell <> "" Or Column B cell <> 0) then, select that row (i.e. Range("A1:B1")).
After the loop, I will copy whatever is selected and paste it to a specific row.
However, I want to keep adding to that selection as it loops through each row and only if it satisfies the If condition, so I'm able to copy it all once at the end. How do I go about combining this?
A B
1 Abc 1
2 Def 2
3 Geh 3
This is how you can expand current selection:
Sub macro1()
Set selectedCells = Cells(1, 2)
Set selectedCells = Application.Union(selectedCells, Cells(2, 3))
selectedCells.Select
End Sub
I'm sure you can manage the rest of your code by yourself, it's really easy. You already mentioned everything you need: For Each cell In Range("B1:B5") and If statement
Please try the below code
Sub test()
Application.ScreenUpdating = False
Dim rng As Range, one As Variant
Dim i As Integer
'Change the sheet and range name as yours
'Finding lastrow of destination column
i = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
' getting input from user
Set rng = Application.InputBox("Please select a range of cells!", "Please select a range", Selection.Address, , , , , 8)
For Each one In rng
If one.Value <> "" Or one.Value <> 0 Then
Range(one.Offset(0, -1), one).Copy
'Change the sheet and range name as yours
Sheets("Sheet2").Activate
Range("A" & i).Select
ActiveSheet.Paste
i = i + 1
End If
Next one
Application.ScreenUpdating = True
End Sub
The above macro will prompt you for the input range to be validate and copy to sheet2 in column A.
The below code will validate and copy paste the current selected range to sheet2 column A
Sub test()
Application.ScreenUpdating = False
Dim rng As Range, one As Variant
Dim i As Integer
'Chnage the sheet and range name as yours
'Finding lastrow of destination column
i = Sheets("Sheet2").Cells(Rows.Count, "A").End(xlUp).Row + 1
' getting input from user
Set rng = Selection
For Each one In rng
If one.Value <> "" Or one.Value <> 0 Then
Range(one.Offset(0, -1), one).Copy
'Chnage the sheet and range name as yours
Sheets("Sheet2").Activate
Range("A" & i).Select
ActiveSheet.Paste
i = i + 1
End If
Next one
Application.ScreenUpdating = True
End Sub
I think you're probably going about this the wrong way. Do you already know to where you would like to copy all the data in the end? It sounds like it, as you refer to copying it "to a specific row". If so, you'd be better off using your macro to copy the data from Columns A:B on the fly.
So, for example:
Sub CopyData()
Const SOURCE_COLUMN1 As Long = 1 ' A
Const SOURCE_COLUMN2 As Long = 2 ' B
Const TARGET_COLUMN1 As Long = 5 ' E
Const TARGET_COLUMN2 As Long = 6 ' F
Dim lngSourceRow As Long
Dim lngTargetRow As Long
With ThisWorkbook.Sheets("Sheet1")
lngSourceRow = 1
lngTargetRow = 0 ' Change this to the row above the one you want to copy to;
Do While .Cells(lngSourceRow, SOURCE_COLUMN1) <> ""
If .Cells(lngSourceRow, SOURCE_COLUMN2) <> "" Then
lngTargetRow = lngTargetRow + 1
.Cells(lngTargetRow, TARGET_COLUMN1) = .Cells(lngSourceRow, SOURCE_COLUMN1)
.Cells(lngTargetRow, TARGET_COLUMN2) = .Cells(lngSourceRow, SOURCE_COLUMN2)
End If
lngSourceRow = lngSourceRow + 1
Loop
End With
End Sub