#TimWilliams if I define CellArray matrix as range then it crashes on the code to build the matrix, I followed the answer posted at the link that you have indicated https://stackoverflow.com/a/8320884/11835835
Dim CellsArray(3,3) As Range
For X = 0 To 2
For Y = 0 To 2
CellsArray(X, Y) = Cells(X+1,Y+1) _
.Address(RowAbsolute:=False, ColumnAbsolute:=False) 'it crashes here run-time error 91
Next Y
Next X
For K = 1 To 2
ActiveSheet.Union(Range(CellsArray(0, 0), CellsArray(0, K))).Select
Next K
Instead it works if I define CellsArray matrix as string
Dim CellsArray(3,3) As String
but then it crashes on
ActiveSheet.Union(Range(CellsArray(0, 0), CellsArray(0, K))).Select
with run time error 438
Try this:
Dim CellsArray(1 To 3, 1 To 3) As Range 'easier to use a 1-based array
For X = 1 To 3
For Y = 1 To 3
Set CellsArray(X, Y) = Cells(X, Y) 'Need Set here
Next Y
Next X
I'm not sure what you want to do here...
Dim rng As Range
For K = 1 To 3
If rng is nothing then
Set rng = CellsArray(1, 1)
Else
Set rng = Application.Union(rng, CellsArray(1, K))
End If
Next K
rng.Select
Related
I'm writing a code which goes into different sheets and performs GoalSeek on rows that have the word "Obj" and "Var". After completing my first sheet, the code moves on to the second sheet and prompted the error 1004. It says my reference for the Do ... Loop function is no longer valid. Why could that be?
Sub GoalSeek()
Dim FirstAddress As String
Dim SecondAddress As String
Dim Arr As Variant
Dim Rng As Range
Dim Rng2 As Range
Dim y As Long
Dim i As Long
Arr = Array("SheetA", "SheetB")
For i = LBound(Arr) To UBound(Arr)
With Worksheets(Arr(i)).Range("A1:BZ500")
Set Rng = .Find("Obj", LookIn:=xlValues)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Set Rng2 = .Find("Var", LookIn:=xlValues)
If Not Rng2 Is Nothing Then
SecondAddress = Rng2.Address
'Error Occurred Here
Do
Rng.Offset(0, y + 1).GoalSeek Goal:=0, ChangingCell:=Rng2.Offset(0, y + 1)
y = y + 1
Loop Until y = 12
End If
End If
End With
Next i
End Sub
I think this might be your issue:
You initialise y at the beginning,
dim y as long
and by default it has the value 0. You make this assumption during your loop
Do
Rng.Offset(0, y + 1).GoalSeek Goal:=0, ChangingCell:=Rng2.Offset(0, y + 1)
y = y + 1
Loop Until y = 12
For the first sheet, y=0,1,2,3,...,12 then the loop stops. Then you leave y=12 and move onto your next sheet.
So for the second sheet you go into the Do loop with y=12 and get an error. You should amend your code to the following:
y = 0
Do
Rng.Offset(0, y + 1).GoalSeek Goal:=0, ChangingCell:=Rng2.Offset(0, y + 1)
y = y + 1
Loop Until y = 12
If you'd used a Do While ... Loop instead, you would probably have noticed this sooner because the loop would never even have been entered as the condition wasn't met.
y = 0
Do While y < 12
Rng.Offset(0, y + 1).GoalSeek Goal:=0, ChangingCell:=Rng2.Offset(0, y + 1)
y = y + 1
Loop
Really though, for a loop this simple, a For loop will always be easier to diagnose than a Do loop...
For y = 0 to 11
Rng.Offset(0, y + 1).GoalSeek Goal:=0, ChangingCell:=Rng2.Offset(0, y + 1)
Next y
My problem is the as follows:
I have 3 columns and 20 rows, that contains numbers.
There is a line with numbers between 1 to 20 in order crescente, the other cells contains bigger numbers then 100 or whatever.
My homework is that I have to write a VBA code which fill color the cells that contains the line. This way i going to have a "colorful snake" from the cells that contains the numbers between 1 to 20.
Of course, the starting number cell is "A1"
the ending cell can be anywhere in the area "A1:C20"
the substance is the colored cells must have follow the numbers in order cresence!
Sub MeykEhYewowSnakhey()
Dim r, c
Dim ws As Worksheet
Set ws = ThisWorkbook.Worksheets(1)
For r = 1 To ws.UsedRange.Rows.Count
For c = 1 To ws.UsedRange.Columns.Count
If ws.Cells(r, c).Value < 100 Then
ws.Cells(r, c).Interior.ColorIndex = 6
End If
Next
Next
End Sub
Try that.
There is probably a much more efficient way to solve this but this is my solution.
Sub Snake()
Dim wbk As Workbook
Dim ws As Worksheet
Dim mySnake As Integer, x As Integer, y As Integer
Set wbk = Workbooks("Book1.xlsm")
Set ws = wbk.Worksheets("Sheet1")
x = 1
y = 1
With ws
For mySnake = 1 To 20
If .Cells(x, y) = mySnake Then
.Cells(x, y).Interior.Color = vbYellow
'Check cell below
If .Cells(x + 1, y) = mySnake + 1 Then
x = x + 1
'Check cell to right
ElseIf .Cells(x, y + 1) = mySnake + 1 Then
y = y + 1
'Check cells to left if y <> 1
ElseIf y <> 1 Then
If .Cells(x, y - 1) = mySnake + 1 Then
y = y - 1
End If
'Check cells above if x <> 1
ElseIf x <> 1 Then
If .Cells(x - 1, y) = mySnake + 1 Then
x = x - 1
End If
End If
End If
Next mySnake
End With
End Sub
I've found an interesting problem with Excel VBA's Cut and paste involving the use of a defined Range Object.
Here's the code that doesn't work:
Sub PasteToRangeDoesntWork()
Dim StRng As Range
Dim j, k, x, y As Integer
Set StRng = Range("A3")
x = 0
j = Range(StRng, StRng.End(xlToRight)).Columns.Count
k = WorksheetFunction.Max(Range(StRng, StRng.End(xlDown)))
For y = 1 To k
While StRng.Offset(x, 0) = y
x = x + 1
Wend
If y < k Then
Range(StRng.Offset(x, 0), StRng.End(xlDown).Offset(o, j - 1)).Select
Selection.Cut
Set StRng = StRng.Offset(0, j + 1)
ActiveSheet.Paste Destination:=StRng
x = 0
End If
Next y
End Sub
The problem is that when pasting to the defined StRng, the StRng object disappears and becomes and undefined object.
There's a simple fix, which I've done below.
Sub PasteToRangeWorks()
Dim StRng As Range
Dim j, k, x, y As Integer
Set StRng = Range("A3")
x = 0
j = Range(StRng, StRng.End(xlToRight)).Columns.Count
k = WorksheetFunction.Max(Range(StRng, StRng.End(xlDown)))
For y = 1 To k
While StRng.Offset(x, 0) = y
x = x + 1
Wend
If y < k Then
Range(StRng.Offset(x, 0), StRng.End(xlDown).Offset(o, j - 1)).Select
Selection.Cut
Set StRng = StRng.Offset(0, j)
ActiveSheet.Paste Destination:=StRng.Offset(0, 1)
Set StRng = StRng.Offset(0, 1)
x = 0
End If
Next y
End Sub
This works -- i.e. by not pasting the new cells directly to the StRng and instead to StRng.offset(0,1), the StRng object remains defined.
The Data in question are five columns across. The first column is an integer (with values going from 1 to 7), the next column is text followed by a column with dates and finally, two columns of general format data (2 decimal points).
The fix is not difficult but I'm perplexed as to why the first code doesn't work. Does anyone have ideas?
If you use the .Paste method, then all defined ranges that fall withing the paste boundaries will be reset. The exact "Why?" is something only Microsoft can explain I'm afraid.
A better alternative is to work with the Range.Value and Range.Clear members; these won't cause this issue, are faster, and also don't mess with the clipboard. Note however that this only copies the values and not the formatting nor any formulas.
The code for this can be something like this:
Dim SourceRng As Range
Set SourceRng = Range(StRng.Offset(x, 0), StRng.End(xlDown).Offset(0, j - 1))
Set StRng = StRng.Offset(0, j + 1)
Dim DestRng As Range
Set DestRng = StRng.Resize(SourceRng.Rows.Count, SourceRng.Columns.Count)
DestRng.Value = SourceRng.Value
Call SourceRng.Clear
What I am trying to do is develop a model that takes a cell that is greater than 1 then to take the sum of the area to the first row using a cone shape, so for example cell D4, sum the area C3:C5 + B2:B6 + A1:A7.
At the moment I have this but it obviously is not working.
Dim I As Double
Dim J As Double
Dim Size As Integer
Dim x As Integer
Dim y As Integer
Dim z As Integer
'Dim Range As Integer
Dim PV1 As Integer
'MCArray = Worksheets("Data")
I = WorksheetFunction.CountA(Worksheets("Data").Rows(1))
J = WorksheetFunction.CountA(Worksheets("Data").Columns(1))
'Loop to Move down the rows
For x = 1 To J
'Loop to move acoss the columns
For y = 1 To I
'IfElse to determine if cell value is greater or equal to zero
If Cells(J, I).Value >= 0 Then
'Loop to sum the cells above
For z = 1 To J
PV1 = (ActiveCell.Value) + Worksheet.Sum(Range([J - z], [I-z:I+z]))
'IfElse to determine if final sum is greater than zero
If PV1 > 0 Then
Worksheets("MC").Range("B4").Value = PV1
Range([J - z], [I-z:I+z]).Interior.ColourIndex = 1
End If
Next z
End If
Next y
Next x
Here is a function you can use either as a UDF or from another routine. Just pass it the single cell you want to start from (D4 in your example) and this function will calculate the sum of the cone as you described.
Public Function SUMCONE(r As Range) As Double
Application.Volatile
SUMCONE = Application.Sum(r, r(-0, -0).Resize(, 3), r(-1, -1).Resize(, 5), r(-2, -2).Resize(, 7))
End Function
Here is an example of how to use the above function from your VBA routine:
Public Sub Demo()
Dim j&
For j = 5 To 10
If Cells(5, j) > 0 Then
Debug.Print SUMCONE(Cells(5, j))
End If
Next
End Sub
UPDATE
Based on your feedback I have updated the function and the demo routine to form an upward cone summation from the initial cell.
UPDATE #2
The above is for a fixed-size cone, extending upwards, that can be initiated from any cell in the worksheet.
But if you would prefer for the cone to always extend all the way up to row 1 regardless of which cell it originates in, then the following is what you are after:
Public Sub Demo()
Dim i&, j&
For j = 1 To Application.CountA(Worksheets("Data").Rows(1))
For i = 1 To Application.CountA(Worksheets("Data").Columns(1))
If Cells(i, j) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
UPDATE #3
As I suspected there was a problem if the cone was initiated too close to the left edge of the worksheet. I've added code to handle that now. Also your method for accessing the large matrix (which I had used in the Demo routine) did not work properly. I fixed that as well:
Public Sub Demo()
Dim i&, j&
For j = 1 To Cells(1, Columns.Count).End(xlToLeft).Column
For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
If Val(Cells(i, j)) > 0 Then
Debug.Print Cells(i, j).Address, SumAndColorCone(Cells(i, j))
End If
Next
Next
End Sub
Public Function SumAndColorCone(r As Range) As Double
Dim i&, k&, c As Range
Set c = r
For i = r.Row - 1 To 1 Step -1
If r.Column - k < 2 Then Exit For
Set c = Union(c, r(-k, -k).Resize(, (k + 1) * 2 + 1))
k = k + 1
Next
c.Interior.Color = vbRed
SumAndColorCone = Application.Sum(c)
End Function
Here is some code that gives me a Object defined or Application defined error. Can you guys please help? Thanks in advance
The error comes on the check for matching cell line.
Sub check()
Dim y, x, xb As Integer
'vertical step
For y = 12 To 65
'check if cell have value
If Not IsEmpty(Sheet2.Cells(y, 4)) Then
'horizontal step
For x = 70 To 600
xb = x + 1
'checks for matching cell value
If Sheet2.Cells(6, x).Value = Sheet2.Cells(y, 4).Value Then
'sees if the next col over after match is empty
If Not IsEmpty(Sheet2.Cells(y, xb)) Then
'if not then highlight cell in col d
Sheet2.Cells(y, 4).Interior.ColorIndex = 3
End If
End If
Next x
End If
Next y
End Sub
You need to define Sheet2. You can do that by declaring it at the top of your code with:
Dim Sheet2 As Worksheet
Set Sheet2 = ThisWorkbook.Worksheets("Sheet2")
From there you can use With Sheet2 to use it like so:
Sub check()
Dim y, x, xb As Integer
Dim Sheet2 As Worksheet
Set Sheet2 = ThisWorkbook.Worksheets("Sheet2")
'vertical step
With Sheet2
For y = 12 To 65
'check if cell have value
If Not IsEmpty(.Cells(y, 4)) Then
'horizontal step
For x = 70 To 600
xb = x + 1
'checks for matching cell value
If .Cells(6, x).Value = .Cells(y, 4).Value Then
'sees if the next col over after match is empty
If Not IsEmpty(.Cells(y, xb)) Then
'if not then highlight cell in col d
.Cells(y, 4).Interior.ColorIndex = 3
End If
End If
Next x
End If
Next y
End With
End Sub