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
Related
#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
Here is an example of what I am trying to accomplish:
I am trying to add an "x" in the next 3 blank cells that are next to a nonblank cell (from left to right). I do not want to overwrite any cells though. As you can see in the first row, only December and January are filled and I did not overwrite February.
Any ideas?
Sub sub1()
Dim irow&, icol&, n&
For irow = 2 To 6 ' rows
n = 0
For icol = 2 To 14 ' columns
If Cells(irow, icol) = "" Then
n = n + 1
If n <= 3 Then Cells(irow, icol) = "x"
Else
n = 0
End If
Next
Next
End Sub
For Each ID In Range("A2:A6") 'Change your range according your ID
For Each cell In ID.EntireRow.Cells 'Check each cell of ID's row
If cell.Value = "" Then
cell.Value = "x"
No = No + 1
Else
No = 0 'Recount
End If
If No = 3 Then Exit For 'stop after mark 3 x
Next
Next
you could use this
Option Explicit
Sub main()
Dim cell As Range, nCols As Long
With ActiveSheet.UsedRange.SpecialCells(xlCellTypeBlanks)
For Each cell In .Cells
nCols = WorksheetFunction.Min(cell.Column - 1, 3)
If Intersect(cell.Offset(, -nCols).Resize(, nCols + 1), .Cells).Count < 4 Then cell.Value = "x"
Next
End With
End Sub
Cant seem to figure out why my code is not showing output. New VBA programmer only know basics so any help would be helpful.
What I want is for Excel to start checking a specific column for a specific text1 and then start copying and pasting those values till it reaches text2. After that I want it to check the next fifth column in the same manner.
If you could suggest modifications to my code.
Without putting in a for loop for the column my code looks like this.
Private Sub CommandButton7_Click()
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 1 'first row
a = 70 'this is the row where i want the data to be posted
If Cells(x, y).Value = "text1" Then 'check first for specific text
Do Until Cells(x, y).Value = "text2" 'stop here
Cells(a, y).Value = Cells(x, y).Value 'copy that data to new row
Cells(a, y + 1).Value = Cells(x, y + 1).Value 'and the column adjacent to it
x = x + 1
a = a + 1
Loop
Else
x = x + 1 'if not on that row then check the next row
End If
End Sub
Really hard to see what is going wrong here as your code should be doing what you want.
The only other thing that could throw your results is when you have different case ,as VBA will treat a string with an upper case character as being different, so you may not actually be entering the loop at all. And I am assuming that text1 is just a sample string for the question.
So comparing the string in lower case will ensure that if you have any upper case characters they will be compared correctly, using the LCase function should help with that.
Full code,
Private Sub CommandButton7_Click()
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 1 'first row
a = 70 'this is the row where i want the data to be posted
If LCase(Cells(x, y).Value) = LCase("text1") Then 'check first for specific text
Do Until LCase(Cells(x, y).Value) = LCase("text2") 'stop here
Cells(a, y).Value = Cells(x, y).Value 'copy that data to new row
Cells(a, y + 1).Value = Cells(x, y + 1).Value 'and the column adjacent to it
x = x + 1
a = a + 1
Loop
Else: x = x + 1 'if not on that row then check the next row
End If
End Sub
Kind of hard to see the big picture but I think I produced the result you want with:
Sub FindText()
Dim textFound As Range
Dim x As Long, y As Long
Dim a As Long
y = 1 'starts with the first column
x = 0 'first row
a = 70 'this is the row where i want the data to be posted
Set textFound = ActiveSheet.Columns(y).Cells.Find("Text1")
Do Until textFound.Offset(x, 0).Value = "Text2"
Cells(a + x, y).Value = textFound.Offset(x, 0).Value
Cells(a + x, y + 1).Value = textFound.Offset(x, 1).Value
x = x + 1
Loop
End Sub
This code is far from perfect but should work in most circumstances.
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 have a code that works, but I want to add some more functionality to it. It currently does what it is supposed to do, and has sped up some processes, but now I think it can be sped up even more. I am using the solution that I marked as answered here: Using VBA to get a threshold value
But
I have this code:
Sub OutputEnergyToAllSheets()
Dim w
For Each w In ThisWorkbook.Worksheets
If Not InStr(w.Name, "Total") > 0 And Not InStr(w.Name, "eV") Then
OutputEnergyToSheet w.Name
End If
Next w
End Sub
Sub OutputEnergyToSheet(TheSheet As String)
'y = Columns to check: 2-25
'x = Rows to check: 2-152
'z = check the next 4 cells
Dim x, y, z, check
'Clear the range where we store the #N/A or Energy Outputs
With Sheets(TheSheet)
.Range("B153:Y153") = vbNullString
For y = 2 To 25
For x = 2 To 152
If .Cells(x, y) > .Range("Z2") Then 'If value is greater than Z2
check = True 'Let's check the next 4
For z = 1 To 30 'If any of them fail
If .Cells(x + z, y) < .Range("Z2") Then
check = False 'The check fails
Exit For
End If
Next z
If check = True Then 'If the check doesn't fail
.Cells(153, y) = Int(.Cells(x, 1)) 'Set cell 153 to the energy level
Exit For
End If
End If
Next x 'If no energy level was set - #N/A
If .Cells(153, y) = vbNullString Then .Cells(153, y) = ""
Next y
End With
End Sub
But the line that says:
for z = 1 to 30
I am having to change from 0 to 100 in increments of 1. It outputs these values where it should on all worksheets and then I go to the sub and increase value and repeat. The values are output in each worksheet except a few in row 153. Is there a way to have 0 be in row 153, 1 be in 154, 2 in 155, etc up to 100? I understand if this is not possible, but it would me a TON of time, because I have to go through this process for many workbooks. If this can be done it will save me several monotonous hours of busy-work. Anyways, thanks for reading.
For this first code block, I tried to stay with the general structure of the code in your question. I could have for example swapped out the innermost two For loops for a single While loop. That would be more efficient but requires a significant logic change. I did make some changes though. I set everything to "N/A" at the beginning instead of the end and I added a condition to the last If statement. To implement your new functionality of checking for variable numbers of consecutive cells, I included another For loop with counter k around the For loop with counter z and made the end point of z dependent on k. We print out to row 152 + k.
Sub OutputEnergyToSheet(TheSheet As String)
'y = Columns to check: 2-25
'x = Rows to check: 2-152
'k = number of matches in a row to find
'z = check the next (k - 1) cells
Dim x, y, z, check, k
'Clear the range where we store the N/A or Energy Outputs
With Sheets(TheSheet)
.Range("B153:Y252") = "N/A"
For y = 2 To 25
For x = 2 To 151
If .Cells(x, y) > .Range("Z2") Then 'If value is greater than Z2
For k = 1 To 100
check = True 'Let's check the next k - 1
For z = 1 To k - 1 'If any of them fail
If .Cells(x + z, y) <= .Range("Z2") Then
check = False 'The check fails
Exit For
End If
Next z
If check = True And .Cells(152 + k, y) = "N/A" Then
.Cells(152 + k, y) = Int(.Cells(x, 1))
End If
Next k
End If
Next x
Next y
End With
End Sub
Before I did all this, I threw together my own method which is cleaner and runs much faster. The code below steps down the rows and maintains a running count of how many consecutive matches it has found. It eliminates a lot of checks because it only checks any given cell once. Down to 2 total loops! The code above was checking a cell many times over in the inner loops. The below code could probably be better by maintaining the values in an array (read/write in Excel is slow) and/or maintaining a counter of the maximum length I have already achieved for the current column. I stored most of my numbers as variables that can be easily and confidently modified.
Sub EfficientEnergy(ws As Worksheet)
Dim r As Integer, c As Integer, ctr As Integer
Dim compVal As Double
Dim maxRow As Integer, maxCol As Integer, maxConsecutive As Integer
maxRow = 151
maxCol = 25
maxConsecutive = 100
compVal = ws.Cells(2, 26).Value
ws.Range(ws.Cells(maxRow + 2, 2), ws.Cells(maxRow + maxConsecutive + 1, maxCol)).Value = "N/A"
For c = 2 To maxCol
ctr = 0
For r = 2 To maxRow
If ws.Cells(r, c).Value > compVal Then
ctr = ctr + 1
If ws.Cells(maxRow + 1 + ctr, c).Value = "N/A" Then
ws.Cells(maxRow + 1 + ctr, c).Value = ws.Cells(r - ctr + 1, 1).Value
End If
Else
ctr = 0
End If
Next r
Next c
End Sub
The code I am using to call these methods in my testing is (just comment out whichever one you aren't using):
Public Sub GetConsecutiveVals()
'OutputEnergyToSheet ("Sheet1")
Call EfficientEnergy(ActiveWorkbook.Worksheets("Sheet1"))
End Sub
Or to run on every worksheet in active workbook (untested):
Public Sub GetConsecutiveVals()
Dim ws As Worksheet
For Each ws In ActiveWorkbook.Worksheets
'OutputEnergyToSheet (ws.Name)
Call EfficientEnergy(ws)
Next ws
End Sub
Place all your code in a module in a workbook. Open your workbook with data in Sheet1 (or change the code above to your sheet name). Hit Alt + F8 and then run the GetConsecutiveVals routine. If you don't see that method in the dialog window, make sure the workbook with the code and the workbook with your data are in the same Excel application window
#jack This is how i read this code. Check all cells from Column 2 - 25, Rows 2 - 152, if one of them is greater than Z2, Enter Zloop, Begin checking the next 30 rows, to see if any of those are smaller. if so do nothing, if one is, in cell 153,y = Column 1 same row, go to next column ..question: Why have Z only check 30? why not have it check the remaining 152 ...z= 1 to 152 - x ?
in any case i think this is what you want to do, create another variable say
DIM Result As Integer
Result = 153
''then below
If check = True Then 'If the check doesn't fail
''.Cells(153, y) = Int(.Cells(x, 1)) 'Set cell 153 to the energy level
.Cells(Result, y) = Int(.Cells(x, 1)) 'Set cell 153 to the energy level
Result = Result + 1
EXIT FOR
Why use three loops when one would do?
Sub OutputEnergyToAllSheets()
Dim w as worksheet
For Each w In ThisWorkbook.Worksheets
If Not InStr(1, w.Name, "Total") > 0 And Not InStr(1, w.Name, "eV") Then
OutputEnergyToSheet w.Name
End If
Next w
End Sub
Sub OutputEnergyToSheet(TheSheet As String)
Dim check as Boolean
Dim rng as Range
Dim c
Dim ELevel as integer
'Clear the range where we store the #N/A or Energy Outputs
With Sheets(TheSheet)
' set all cells in row 153 = 0
.Range("B153:Y153").value = 0
ELevel = .cells(2,26)
' Your range
set rng = .Range(.Cells(2,2), .cells(25, 153))
' Loop through all cells in range
For each c in rng.cells
' If value is greater then Z2 and respective column in row 153 = 0 and cell is not in 153 then change 153 = respective row column 1
If c.value > ELevel and .cells(153, c.column) = 0 and c.row <> 153 Then
.cells(153,c.column) = .cells(c.row, 1)
' If value is less then Z2 and cell is not in 153 then change 153 = 0
elseif c.value < ELevel and c.row <> 153 then
.cells(153, c.column) = 0
' Clean up - if cell is in row 153 and value = 0 then change to "N/A"
elseif c.row = 153 and c.value = 0 then
c.value = "N/A"
end if
Next c
End With
End Sub
Please let me know if I've misunderstood