I have the following UDF, saved into a module of my workbook:
Function sumAbove2(myCell As Range)
Dim rng As Range, cel As Range
Dim topRow As Long
topRow = myCell.Offset(0, -2).End(xlUp).Row
Dim sRng As Range, eRng As Range
Set sRng = Cells(myCell.Row, myCell.Column)
Set eRng = Cells(topRow, myCell.Column)
For Each cel In Range(sRng, eRng)
Debug.Print cel.Address
sumAbove2 = cel.Value + sumAbove2
Next cel
End Function
The idea is to automatically sum "blocks" of information.
The UDF works just fine when I walk through it with F8. But, when running automatically, it can give unexpected results. The annoying thing is that I have placed this code in a brand new workbook, threw in sample data, and it never generated incorrect results...so for that, I apologize my SO friends, I can't quite get it to reproduce. I'm relatively new to UDF, so may be missing some key point about running them (does volatility help/hurt?)
And when I do this, two seconds later, with a Break in the macro, I can step through with F8, it correctly adds nothing, and returns 0.
What could be going on? I didn't specify the sheet in the code, but I can't see why that would fix it. Could it have to do with some other formulas on the page? There's no worksheet_change event, etc.
Edit: The workbook has a few sheets, with formulas in those sheets. But the sheet I'm running this on is all text, save the formula I'm trying to enter. Just thought to mention in case something in formatting could be giving the odd behavior.
I would 1) simplify the code a bit (you're not using the rng variable for anything and you don't really need the start and end row ranges in separate variables), 2) define the data type to be returned, 3) use fully qualified references and 4) add a numeric check the following way:
Function sumAbove2(myCell As Range) As Double
Dim actSht As Excel.Worksheet
Dim topRow As Long
Dim cel As Range, searchRng As Range
topRow = myCell.Offset(0, -2).End(xlUp).Row
Set actSht = ActiveSheet
With actSht
Set searchRng = .Range(.Cells(myCell.Row, myCell.Column), .Cells(topRow, myCell.Column))
End With
For Each cel In searchRng
If IsNumeric(cel.Value) Then sumAbove2 = cel.Value + sumAbove2
Next cel
End Function
Seems to work flawlessly by me.
You need to fully qualify all your ranges with the correct worksheet...
Function sumAbove2(myCell As Range)
Dim sht As Worksheet '<<<
Dim rng As Range, cel As Range
Dim topRow As Long
Dim sRng As Range, eRng As Range
Set sht = myCell.Worksheet '<<<
topRow = myCell.Offset(0, -2).End(xlUp).Row
Set sRng = sht.Cells(myCell.Row, myCell.Column) '<<<
Set eRng = sht.Cells(topRow, myCell.Column) '<<<
For Each cel In sht.Range(sRng, eRng) '<<<
Debug.Print cel.Address
sumAbove2 = cel.Value + sumAbove2
Next cel
End Function
Edit: debugging UDF #VALUE errors from the worksheet is tricky - you will get more information if you debug by calling the function from a test sub:
Sub Tester()
Debug.Print sumAbove2(Activesheet.Range("C44"))
End sub
Related
Project Outline: The project I'm working on consists of a file with 2 sheets. The first sheet is a Dashboard of Reports with inputs about who worked it, what department it was for, and the timeframe of each report. This information is then transferred to a second sheet via a Button.
Right now the button copies the data from Dashboard to Data, adding the new information, starting in the first blank row (counted up from the bottom) of Column B. It then requests a Date input for that data from the user.
What I want to happen next:
I need to find the Range based on where the last input from Column A is, to where the last input of Column B is.
Example: Say there is Data from A1:A345. Say there is also Data from B1:B764. I need the VBA script to pull the range A346:A764 so I can then tell it to apply the Date from the input box in Column A for that range. (The dates may be historical and/or out of order so the input from the user is important. )
I'm currently using :
sh2.Cells(Rows.Count, 1).End(xlUp) - to Find the range of Column A
sh2.Cells(Rows.Count, 2).End(xlUp) - to Find the range of Column B
I'm having trouble figuring out a way to compare on range to the other in order to return the correct range for the data.
I've attempted using:
DO UNTIL (Excel crashed, it seems to loop continuously and I'm having trouble finding a way to get it to recognize when to stop)
DO UNTIL Attempt
`sh2.Cells(Rows.Count, 1).End(xlUp)(2).Select
Do Until IsEmpty(ActiveCell.Offset(, 1))
sh2.Cells(Rows.Count, 1).End(xlUp)(2).Value = myDate
Loop`
LOOP UNTIL (Excel crashed, same as above)
FOR EACH with IF NOT (I can't quite figure out how to compare the ranges to return a usable value)
FOR EACH Attempt
`Dim AColLR As Long
Dim BColLR As Long
Dim rngA As Range
Dim rngB As Range
Dim rngC As Range
Dim cell As Range
AColLR = sh2.Cells(Rows.Count, 1).End(xlUp).Row
BColLR = sh2.Cells(Rows.Count, 2).End(xlUp).Row
'Set rngB = sh2.Range("B2:B" & BColLR)
Set rngC = sh2.Range(BColLR - AColLR)
For Each cell In rngC
If Not IsEmpty(cell.Value) Then
cell.Offset(, -1).Value = myDate
End If
Next cell`
FUNCTION (I wasn't able to figure out how to call the function in the Sub, also Function might be broken?)
FUNCTION Attempt
`Function SetDifference(rngA As Range, rngB As Range) As Range
Dim sh1 As Worksheet, sh2 As Worksheet
Set sh1 = Sheets("Dashboard")
Set sh2 = Sheets("Data")
AColLR = sh2.Cells(Rows.Count, 1).End(xlUp).Row
BColLR = sh2.Cells(Rows.Count, 2).End(xlUp).Row
rngA = sh2.Range("A2:A" & AColLR)
rngB = sh2.Range("B2:B" & BColLR)
On Error Resume Next
If Intersect(rngA, rngB) Is Nothing Then
'if there is no common area then we will set both areas as result
Set SetDifference = Nothing
'alternatively
'set SetDifference = Nothing
Exit Function
End If
On Error GoTo 0
Dim aCell As Range
For Each aCell In rngA
Dim Result As Range
If Application.Intersect(aCell, rngB) Is
Nothing Then
If Result Is Nothing Then
Set Result = aCell
Else
Set Result = Union(Result, aCell)
End If
End If
Next aCell
Set SetDifference = Result
End Function`
I'm not sure which method is actually the correct one to use for this type of referencing.
Any assistance would be most appreciated!!
Something like this should work:
Dim cA As Range, cB As Range, ws As Worksheet, rng As Range
Set ws = ActiveSheet 'or some specific sheet
With ws
Set cA = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
Set cB = .Cells(.Rows.Count, "B").End(xlUp).Offset(0, -1)
Set rng = .Range(cA, cB)
End With
rng.Value = "dateHere"
I need to fill in the table in the image by plugging in the values of mass and acceleration in C15 and C16 respectively and copying the corresponding value of force from C17 to the table.
Any help will be appreciated.
Sub NestedLoop()
Dim cell As Range, rgSource1 As Range, rgDestination1 As Range, cell2 As Range, rgSource2 As Range, rgDestination2 As Range
Set rgSource1 = ThisWorkbook.Worksheets("sheetname").Range("A1:A6")
Set rgSource2 = ThisWorkbook.Worksheets("sheetname").Range("B1:E1")
Set rgDestination1 = ThisWorkbook.Worksheets("SHEETNAME").Range("C15")
Set rgDestination2 = ThisWorkbook.Worksheets("SHEETNAME").Range("C16")
For Each cell In rgSource2[![enter image description here][1]][1]
For Each cell2 In rgSource1
rgSource1.Copy
rgDestination1.PasteSpecial xlPasteValues
Next cell2
rgSource2.Copy
rgDestination2.PasteSpecial xlPasteValues
Next cell
End Sub
Multiply First Row By First Column
By using an array, you can simplify the code and increase its efficiency.
The Code
Option Explicit
Sub Multiplication()
Dim rng As Range
Set rng = ThisWorkbook.Worksheets("Sheet1").Range("A1").CurrentRegion
Dim Data As Variant: Data = rng.Value
Dim i As Long
Dim j As Long
For i = 2 To UBound(Data, 1)
For j = 2 To UBound(Data, 2)
Data(i, j) = Data(i, 1) * Data(1, j)
Next j
Next i
rng.Value = Data
End Sub
It's a little difficult to answer your question without knowing something a little closer to the actual problem. I don't know which parts I can modify and which ones I can't. For instance, iterating through the cells copying and pasting seems like the wrong way to go about it, but I don't know exactly what you're trying to accomplish, so I don't know how to suggest. Notice in the code given here I don't paste the answer back, I just figure out where it needs to go and write it there. I have added a sheet object to make range assignment easier, although you can accomplish this entire task without ever using a range at all. Further, I would just about always prefer to work in r1c1 than a1.
Sub NestedLoop()
Dim cell As Range, rgSource1 As Range, rgDestination1 As Range, _
cell2 As Range, rgSource2 As Range, rgDestination2 As Range
Dim this As Worksheet: Set this = ActiveSheet
Set rgSource1 = this.Range("A2:A6")
Set rgSource2 = this.Range("B1:E1")
Set rgDestination1 = this.Range("C15")
Set rgDestination2 = this.Range("C16")
Set rgResult = this.Range("c17")
For Each cell In rgSource2
For Each cell2 In rgSource1
cell.Copy
rgDestination1.PasteSpecial xlPasteValues
cell2.Copy
rgDestination2.PasteSpecial xlPasteValues
this.Cells(cell2.Row, cell.Column) = rgResult
Next
Next
End Sub
Here's the output:
What are the best ways to move excel ranges around using VBA? For as frequently as I need to do it, I still have a lot of trouble with it. I'd like to show my most-used approaches for criticism and/or suggestions of new ways to go about moving ranges.
The cut/copy method seems to be really finicky, especially when multiple worksheets or variables are involved. For example:
Dim wkb1 as Workbook
Dim wks1 as Worksheet, wks2 as Worksheet
Set wbk1 = ThisWorkbook
Set wks1 = wbk1.Worksheets(1)
Set wks2 = wbk1.Worksheets(2)
wks1.Range("A1:A5").Copy (wks2.Range("A1"))
' Error: Object variable or With Block variable not set.
wbk1.Worksheets(1).Range("A1:A5").Copy (wbk1.Worksheets(2).Range("A1"))
' This works.
I would think that avoiding the clipboard increases execution speed. Here, I simply equate one range to another. The drawback is that it requires ranges of equal dimensions:
' Copy a range of two equal dimensions.
WrkSht2.Range("A1:F" & (rngEndRange.row - 10)).Value = _
WrkSht2.Range("A10", rngEndRange).Value
I like the idea of using collections, but there's the draw back of added complexity from needing to work with loops.
Sub UseCollection()
Dim MySheet As Worksheet
Dim lngLastRow As Long
Dim rngSearch As Range, rngCell As Range, rngCopy As Range
Dim MyCollection As New Collection
Set MySheet = ThisWorkbook.Worksheets(1)
Set CopySheet = ThisWorkbook.Worksheets(3)
lngLastRow = MySheet.Range("A1").End(xlDown).Row
Set rngSearch = MySheet.Range("A1:A" & lngLastRow)
Set rngCopy = CopySheet.Range("A1")
For Each rngCell In rngSearch
MyCollection.Add rngCell.Value
Next rngCell
i = 1
For Each Element In MyCollection
rngCopy(i, 1) = Element
i = i + 1
Next Element
End Sub
So how do you all go about copying ranges? Ideally, an approach should be easy to use with worksheet/range variables, and it should be relatively simple.
Yes the range size is a slight faff which is one reason why I often don't bother, but you can do it this way:
Sub x()
Dim r1 As Range
Set r1 = Range("A1:C3")
With r1
Range("F1").Resize(.Rows.Count, .Columns.Count).Value = r1.Value
End With
End Sub
Edit: think this is what BigBen's comment means.
...Or a bit shorter 😎
Sub x()
With Range("A1:C3")
Range("F1").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
End Sub
I'm trying to define a range by the contents of two different cells, each containing the indirect cell addresses. I'm not sure whether it's possible, but here's an example:
Cell X100 contains value $A$1
Cell Y200 contains values $C$5
Is there any way I can use Range() and cells X100 and Y200 to arrive at Range("$A$1:$C$5")?
I've tried using Cells.Address but I can't figure out the right format for the application. Any help is appreciated!
Thanks
Edit
Thank you Tom! I have another question for you. The X100 cell is actually variable in my case, and I was using the following formula to find it:
Cells.Find("ID").Offset(1,0).Address
Is there any way to incorporate this sort of formula into the Range application? Or would it be easier to define a static cell in the spreadsheet containing this formula?
Thanks a bunch
Edit 2
Here you are! I'm dimming r and x as ranges and setting them as follows:
r = Cells.Find("ID").Offset(1,0).Address
x = Cells.Find("Description of initiative").offset(1,0).end(xldown).Offset(0,cells.Find("ID").Column-cells.Find("Description of initiative").Column).address
They're convoluted I know, but I printed them out and they are returning the right cells in the $A$1 format.
Hope this clarifies! Really appreciate your help.
Do you mean
Range(Range("X100").Value2 & ":" & Range("Y200").Value2)
Rather than working with addresses, work with Range objects.
Not sure I fully understand your setup, but something like this is maybe what you're looking for.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim startCell As Range
Set startCell = ws.Cells.Find(What:="ID") '<--- you should specify the other parameters of Find
Dim endCell As Range
Set endCell = ws.Cells.Find(What:="Description of initiative") '<--- again, specify parameters of Find
If startCell Is Nothing Then Exit Sub '<--- Find was unsuccessful
If endCell Is Nothing Then Exit Sub '<--- Find was unsuccessful
Set startCell = startCell.Offset(1, 0)
Dim columnOffset As Long
columnOffset = startCell.Column - endCell.Column
Set endCell = endCell.Offset(1).End(xlDown)
Set endCell = endCell.Offset(, columnOffset) '<--- there's a simpler way to do this, this just gets you back to startCell.Column, but preserving your logic
Dim myRange As Range
Set myRange = ws.Range(startCell, endCell)
End Sub
Here's the simpler way to get endCell instead of the offset.
Sub Test()
Dim ws As Worksheet
Set ws = ActiveSheet
Dim startCell As Range
Set startCell = ws.Cells.Find(What:="ID") '<--- you should specify the other parameters of Find
Dim endCell As Range
Set endCell = ws.Cells.Find(What:="Description of initiative") '<--- again, specify parameters of Find
If startCell Is Nothing Then Exit Sub '<--- Find was unsuccessful
If endCell Is Nothing Then Exit Sub '<--- Find was unsuccessful
Set startCell = startCell.Offset(1, 0)
Dim lastRow As Long
lastRow = endCell.Offset(1).End(xlDown).Row
Set endCell = ws.Cells(lastRow, startCell.Column)
Dim myRange As Range
Set myRange = ws.Range(startCell, endCell)
End Sub
I am trying to rebuild a worksheet we use daily and in the process make it faster. I've been working with ranges now and trying to incorporate those but ran into a problem when trying to use UsedRange to get the last row for the range than finding it.
My code:
Sub RebuildAllFormat()
Dim SheetRNG As Range, RowDelete As Range, SOSheet As Worksheet
Set SOSheet = ThisWorkbook.Worksheets(Sheet1.Name)
Set SheetRNG = SOSheet.UsedRange.Columns(1)
For Each cell In SheetRNG
If cell.Value = "" Then
Cells(cell.Row, "P").Cut Cells(cell.Row - 1, "P")
If Not RowDelete Is Nothing Then
Set RowDelete = Union(RowDelete, cell)
Else
Set RowDelete = cell
End If
End If
Next cell
RowDelete.EntireRow.Delete
End Sub
The above code gives me the "Type Mismatch" error on If cell.Value = "" Then and it appears that the For loop no longer runs through each cell even though I get the expected value from Debug.Print SheetRNG.Address which is $A$1:$A$1736.
If I replace Set SheetRNG = SOSheet.UsedRange.Columns(1) with
lastrow = SOSheet.Cells(Rows.Count, "B").End(xlUp).Row
Set SheetRNG = SOSheet.Range(SOSheet.Range("A1"), SOSheet.Cells(lastrow, "A"))
then the loop works as expected and I'm able to check values. Running Debug.Print SheetRNG.Address after using the above also returns $A$1:$A$1736.
Am I missing something in the UsedRange code or is it not possible to use it that way?
As others have said, and you yourself identified, the issue is that For Each cell In SheetRNG returns the whole ranhe to cell.
Use For Each cell In SheetRNG.Cells to get each cell individually.
There are other issues in the code as well. See below comments for reccomendations
Sub RebuildAllFormat()
Dim SheetRNG As Range, RowDelete As Range, SOSheet As Worksheet
Dim cell as Range '<~~ Dim all variables
Set SOSheet = Sheet1 '<~~ Sheet1 is already a Worksheet reference
Set SheetRNG = SOSheet.UsedRange.Columns(1) '<~~ May overstate the required range, but will work OK
For Each cell In SheetRNG.Cells
If cell.Value = "" Then
'~~ Qualify the Sheet reference, otherwise it refers to the active sheet
With SOSheet
.Cells(cell.Row - 1, "P") = .Cells(cell.Row, "P") '<~~ faster than Cut/Paste
If Not RowDelete Is Nothing Then
Set RowDelete = Union(RowDelete, cell)
Else
Set RowDelete = cell
End If
End With
End If
Next cell
'~~ Avoid error if no blanks found
If Not RowDelete Is Nothing Then
RowDelete.EntireRow.Delete
End If
End Sub
The .Columns(1) statement does not that work the way you have used it. For example:
Set SheetRNG = Range("A1:B19").Columns(1)
is not the same like:
Set SheetRNG = Range("A1:A19")
You can .Resize() this .UsedRange.
Set SheetRNG = SOSheet.UsedRange.Resize(SOSheet.UsedRange.Rows.Count, 1)