I am an absolute VBA beginner. I have been trying to create a function that separates a large range into smaller ranges. However, when I try and iterate over the large range, I get errors 91 and 424 interchangeably. Here is the relevant bit of code:
Dim cell As Range
Set cell = Range(Cells(1, 1), Cells(1, 1))
For Each cell In nonZeroes
question = isTouching(cell, firstfeat)
If question = True Then
Set firstfeat = Union(firstfeat, cell)
cell.Interior.ColorIndex = 3
End If
Next
nonZeroes is a range, defined as such:
Dim nonZeroes As Range
For i = 3 To 87
For j = 3 To 87
If Cells(i, j).Value = 0 Then
End If
If Cells(i, j).Value <> 0 Then
If Not nonZeroes Is Nothing Then
Set nonZeroes = Union(nonZeroes, Cells(i, j))
Else
Set nonZeroes = Cells(i, j)
End If
End If
Next j
Next i
What I'm trying to do here is group together non-zero cells that have been entered in a grid. I am considering cells as part of a group if the cell is adjacent to another non-zero cell.
The error occurs with the For Each line highlighted. What am I doing wrong? I've been googling this for a while and all the solutions I've tried don't work.
I think the error is because, as mentioned in the comments, that your "for each" isn't being used correctly. Try this:
Dim cel
Set nonZeroes = Range(Cells(1, 1), Cells(10, 1)) ' You need to set the range to search through here.
For Each cel In nonZeroes
question = isTouching(cel.Value, firstfeat)
If question = True Then
Set firstfeat = Union(firstfeat, cel.Value)
cell.Interior.ColorIndex = 3
End If
Next
I don't think that'll work straight off the bat, because I don't know what your UDFs are, but that should get you started. I also changed "Dim cell" to "Dim cel" since "cell" is also used by VBA
Related
I am trying to write a VBA code to autofill range A1:A10000 with numbers 1 to 10000 but without entering 1 in A1 and 2 in A2 to create a range.
Basically, I need a code that looks like this:
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
(1,2).AutoFill Destination:=fillRange
Of course this does not work, but you get what it.
Writing and reading to/from the worksheet are some of the slowest actions you can perform. Writing time-efficient code means doing as much in memory as you can.
Try writing all your values into an array, then writing the whole thing to the worksheet in one shot, something like this:
Sub printRange(total As Integer)
Dim i, myRange() As Integer
ReDim myRange(1 To total)
For i = 1 To total:
myRange(i) = i
Next i
'Use Transpose to shift the 1d array into a column
Worksheets("Sheet1").Range("A1:A" & UBound(myRange)).Value = _
Application.WorksheetFunction.Transpose(myRange)
End Sub
For total = 10000, this pretty much runs instantly, even on a ten year old dinosaur desktop.
Dim fillRange As Range
Dim i As Long
Set fillRange = Worksheets("Sheet1").Range("A1:A10000")
With fillRange
For i = .Cells(1, 1).Row To .Cells(.Rows.Count, 1).Row
.Cells(i, 1).Value = i
Next i
End With 'fillRange
Or with AutoFill :
With Worksheets("Sheet1")
Range("A1").Value = 1
Range("A2").Value = 2
Range("A1:A2").AutoFill Destination:=Range("A1:A10000")
End With 'Worksheets("Sheet1")
this should be fast enough
you could use the following function
Function FillNumbers(rng As Range) As Variant
Dim i As Long
ReDim nmbrs(1 To rng.Rows.Count)
For i = 1 To UBound(nmbrs)
nmbrs(i) = i
Next
FillNumbers = Application.Transpose(nmbrs)
End Function
in the following manner
With Worksheets("Sheet1").Range("A1:A10000")
.Value = FillNumbers(.Cells)
End With
Can't you use a simple loop?
For i = 1 to 10000
Worksheets("Sheet1").Cells(i, 1) = i
Next i
Dim fillRagne As Range
Set fillRange = Range(Cells(1, 1), Cells(1000, 1))
For Each cell in fillRange
cell.value = cell.Row
Next cell
Im trying to highlight range of cells when a date is present in the list of holidays. But on running the below code, the Run time error 1004 is displayed. I have even tried handling it in error handler; but it is not working. Can somebody please help me why this error is occuring and resolve the same?
Sub highlight_cells()
Dim myrange As Range
On Error GoTo myerr:
For i = 1 To 10
Set myrange = Range(Cells(1, i), Cells(10, i))
temp = Application.WorksheetFunction.VLookup(Range(Cells(1, i)), [holidays], 2, False)
If (Application.WorksheetFunction.IsNA(temp)) Then
myrange.Interior.Color = 3
End If
Next i
myerr:
If Err.Number = 1004 Then
MsgBox "vlookup error"
End If
End Sub
Range(Cells(1, i)) isn't a valid range reference
maybe you wanted to reference Cells(1, i)
furthermore you can exploit the Application VLookup() method that wraps the possible error in the returned variant variable that you can check with IsError() function like follows:
Dim temp As Variant
For i = 1 To 10
Set myrange = Range(Cells(1, i), Cells(10, i))
temp = Application.VLookup(Cells(1, i), [holidays], 2, False)
If Not IsError(temp) Then Cells(1, i).Interior.Color = 3
Next i
Here is a conditional formatting method, without using VBA.
Select your range > Conditional Formating > New Rule > Use a formula ...
Enter this formula
=VLOOKUP($A2,$J$2:$K$6,1,FALSE)
Take care of the "$" in the formula. This should highlight all cells that were found in the holidays list.
Your code is okay , It worked in Excel 2010 , Your problem is with VBA Error handling method.
Go to Tools --> Options -->General --> Error Trapping
And check "Break on unhanded Errors"
sorry all these times I was referring to column 2 in vlookup. That was causing the problem. The list of holiday is a single column list. Hence vlookup was throwing error. ANd one more thing the named ranges work as I have entered and even the actual range also gives the same result.
Sub highlight_cells()
Dim myrange As Range
For i = 1 To 10
Set myrange = Range(Cells(1, i), Cells(10, i))
MsgBox Cells(1, i)
temp = Application.VLookup(Cells(1, i), [holidays], 1, False)
If Not IsError(temp) Then
myrange.Interior.ColorIndex = 3
End If
Next i
End Sub
So I have the following VBA loop set up, but want to add a line that says "If there are two cells within this range that have a value, do this. If there are three cells within a range that have a value, do that." What I have so far is:
Sub Test1()
Dim Rng As Range
Dim i As Long
i = 3
Application.ScreenUpdating = True
While i <= 133
Set Rng = Range("C" & i)
If Rng.Offset(, 2).Resize(, 7) <> "" Then
Rng.Offset(, 1).FormulaR1C1 = "Blank"
i = i + 1
Else: Stop
End If
Wend
End Sub
So I have the VBA script print the word "Blank" into the appropriate cell if this range is empty. But how can I add more lines to say "If one cell in this range contains a value," or "if two cells in this range contain a value"
Here is how you can check if there are more than one non-empty cell in the given range:
If Application.WorksheetFunction.CountA(Rng.Offset(, 2).Resize(, 7)) > 1 Then
Few additional tips to your code:
If you know exactly the initial and final value of i you should use For ... Next loop instead of While ... Wend. So you could replace this code:
i = 3
'(...)
While i <= 133
'(...)
i = i + 1
Wend
with this:
For i = 3 To 133
'(...)
Next i
I think this line of code will cause Type mismatch error:
If Rng.Offset(, 2).Resize(, 7) <> "" Then
because you are trying to compare an object of Range type with a primitive value (empty string). To avoid this issue you can use the similar code as above:
If Application.WorksheetFunction.CountA(Rng.Offset(, 2).Resize(, 7)) = 0 Then
you might like to add code along these lines
Select case Application.WorksheetFunction.CountA(Rng.Offset(, 2).Resize(, 7))
case 0
Rng.Offset(, 1).value = "Blank"
case 1
Rng.Offset(, 1).value = "Only One"
case >2
Rng.Offset(, 1).value = "More than 1"
end select
Even more VBA Goodness, i've tried writing a for loop with a for loop to go through get the cells text assign it a a variable and then run through a range seeing if the cells value is in range and if found then change another cells value to yes or no if not found but i keep getting all NO's despite being able seeing the values inside the range myself
The whole point is to avoid using vlookup function =if(vlookup("value","Table","col","false"),"Yes","No") which seems to skip some values despite being present.
my code is
Dim xell As Range
For Each xell In Range("C6:C36")
lookFor = xell.Value
For i = 6 To 36
If Cells(i, 10).Value = lookFor Then
Cells(i, 7).Value = "Yes"
Else
Cells(i, 7).Value = "No"
End If
Next i
Next xell
The idea being loop in the first range get the cells text assign it to a variable and start a new loop during this to look through a range to see if the cell value is inside this range.
It executes but comes back with All no.
Turns out i had n exited my loop when finding a yes :)
Exit For was needed
Dim xell As Range
For Each xell In Range("C6:C36")
lookFor = xell.Value
For i = 6 To 36
If Cells(i, 10).Value = lookFor Then
Cells(i, 7).Value = "Yes"
Exit For <-------- was missing
Else
Cells(i, 7).Value = "No"
End If
Next i
Next xell
Didnt solve my current issue of data not being found unless edited
I'm very new to VBA, and I'm trying to move particular items within a column to another sheet for a report.
This is my Macro:
Sub DoIHaveaPRDesignation()
Dim rng As Range
Dim i, Lastrow
Dim splitValues() As String
Lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Range("A1:I500").ClearContents
Sheets("Sheet2").Cells(1, 1).Value = "Pair"
Sheets("Sheet2").Cells(1, 2).Value = "Commit"
Sheets("Sheet2").Cells(1, 3).Value = "CKID"
Sheets("Sheet2").Cells(1, 4).Value = "Status"
Sheets("Sheet2").Cells(1, 5).Value = "Terminal"
Sheets("Sheet2").Cells(1, 6).Value = "Address"
Set rng = ActiveCell
Dim moveValue As String
Do While rng.Value <> Empty
If InStr(rng.Value, " pr") = 0 Then
MsgBox "Haven't found Pair "
Else
MsgBox rng.Value
End If
Set rng = rng.Offset(1)
rng.Select
Loop
MsgBox "Done!"
End Sub
This is one instance of the data (Column A, Rows 1 - 6):
pr 1 stat RCT commit stat P
sys: type 73RMD no 1 slot: 1 lt: field stat DZ7K co stat NREQ
ckid NONE lp stat RCT 11-30-13 bp/clr 601 tea 1975 W SOUTHPORT RD
type FIXED tec IPLPINPL fld side capr 1975W:279
dist tea 7250 WINSLET BLVD type FIXED addr: 7250 WINSLET BLVD
UNIT 2D serv tea 7250 WINSLET BLVD type FIXED
The code finds the occurance of "pr", but I cannot seem to fidgure out how to pick it up and move it. I need to repeat this for the 6 columns I formatted on sheet 2, but if I get help with the first I can figure out the rest.
Thanks!
This answer discusses features of your existing code that are not recommended and introduces techniques that I believe are relevant to your requirement.
Issue 1
Dim i, Lastrow
The above declares i and Lastrow as variants which can hold anything. For example, the following code is valid:
i = "A"
i = 5
Variants can be very useful but they are slower to access than properly typed variables. I recommend:
Dim i As Long, Lastrow As Long
Issue 2
Sheets("Sheet2").Range("A1:I500").ClearContents
I assume Range("A1:I500") is intended to be larger than the area that was used on a previous run of the macro.
I would write Sheets("Sheet2").Cells.ClearContents and let Excel worry about the range used last time.
Note that ClearContents, as the name implies, only clears the contents. Clear will also clear any formatting. Sheets("Sheet2").Cells.EntireRow.Delete will delete contents and formatting and restore the column widths to their default. However, ClearContents may be adequate for your needs.
Issue 3
Sheets("Sheet2").Range("A1:I500").ClearContents
Sheets("Sheet2").Cells(1, 1).Value = "Pair"
Sheets("Sheet2").Cells(1, 2).Value = "Commit"
Sheets("Sheet2").Cells(1, 3).Value = "CKID"
Sheets("Sheet2").Cells(1, 4).Value = "Status"
Sheets("Sheet2").Cells(1, 5).Value = "Terminal"
Sheets("Sheet2").Cells(1, 6).Value = "Address"
Use of the With statement generally makes your code clearer and faster:
With Sheets("Sheet2")
.Range("A1:I500").ClearContents
.Cells(1, 1).Value = "Pair"
.Cells(1, 2).Value = "Commit"
With .Cells(1, 3)
.Value = "CKID"
.Interior.Color = RGB(0, 240, 240)
End With
.Cells(1, 4).Value = "Status"
.Cells(1, 5).Value = "Terminal"
.Cells(1, 6).Value = "Address"
End With
I have coloured cell C1 to show that With statements can be nested.
Issue 4
Set rng = ActiveCell
As I understand it, the source data is in worksheet Sheet1 and starts at cell A1. The above means your code will start at whatever cell in whatever worksheet the user has positioned the cursor. If there is a fixed starting point then set that in your code. If you do want the user to be able to control the starting point consider:
If ActiveCell.Worksheet.Name <> "Sheet1" Then
Call MsgBox("Please position the cursor to the desired starting " & _
"point in worksheet ""Sheet1""", vbOKOnly)
Exit Sub
End If
Issue 5
Set rng = ActiveCell
:
Set rng = rng.Offset(1)
rng.Select
Accessing a selected cell is much slower than accessing the cell using VBA addressing. I have also seen programmers get hopeless confused about the current location of the cursor when using Offset. You have used VBA addressing to set the header row and I have used it in my sample code below.
Issue 6
Lastrow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Do While rng.Value <> Empty
You set Lastrow to the number of the last row with a value but your loop moves down the column until it hits an empty cell. If there are no empty rows within the body of the data, this will give the same result. However I suggest you decide which approach is appropriate.
I would avoid the use of Empty. See What is the difference between =Empty and IsEmpty() in VBA (Excel)?.
Sample code
The following code includes the parts relevant to your question. I move the contents of cells containing " pr" to column 1 of worksheet "Sheet2" which is what you seem to be asking. However, if you wanted to split cells containing " pr" and copy selected parts to Sheet2, I would have handled your requirement in a different way. I can add a further section to this answer if you clarify what you seek.
Option Explicit
Sub MovePRRows()
Dim Rng As Range
Dim RowSheet1Crnt As Long
Dim RowSheet1Last As Long
Dim RowSheet2Crnt As Long
Dim WSht2 As Worksheet
Set WSht2 = Worksheets("Sheet2")
WSht2.Cells.EntireRow.Delete
RowSheet2Crnt = 2
With Worksheets("Sheet1")
RowSheet1Last = .Cells(Rows.Count, "A").End(xlUp).Row
For RowSheet1Crnt = 1 To RowSheet1Last
Set Rng = .Cells(RowSheet1Crnt, 1)
If Rng.Value <> "" Then
If InStr(1, Rng.Value, " pr") <> 0 Then
Rng.Copy Destination:=WSht2.Cells(RowSheet2Crnt, 1)
RowSheet2Crnt = RowSheet2Crnt + 1
End If
End If
Next
End With
End Sub