I am trying to construct and If statement that turns a tab Red if two of three cells are colored, or Turns green if only on is colored. I was hoping that there would be an easier way to right it than three if statements like this.
Dim dateRng As String, num As Integer, j As Integer, irng As Range, frng As Range
dateRng = Sheets("Input Raw Data").Range("B" & counter + 2).Value
num = Sheets("Tool Setup").Range("C18").Value
NumPts = num * 3
For s = 1 To Sheets.Count
With Sheets(s)
For j = 1 To num
If .Name = j Then
.Range("A1:C1").Merge
.Range("A1") = dateRng
.Name = Sheets("Point Names").Range("B" & (3 * j - 1))
End If
Next j
End With
Next s
For s = 1 to Sheets.Count
With Sheets(s)
For y = 1 To NumPts
If .Name = Sheets("Reporting").Range("B" & (12 * y - 5)) Then
For k = 6 To -1
Set irng = Sheets("Reporting").Range("A" & (12 * y - k))
Set irng = Sheets("Reporting").Range(irng, irng.End(xlToRight).End(xlToRight))
irng.Copy (.Range("A2"))
Next k
.Columns("A:A").ColumnWidth = 12
.Columns("B:B").EntireColumn.AutoFit
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a >= 2 Then
.Tab.ColorIndex = 3
ElseIf a <= 1 Then
.Tab.ColorIndex = 4
End If
End If
y = y + 2
Next y
End With
Next s
Something like this may help you. It still has multiple if statements. But the statements are simple and don't have to deal with how the combinations of different cells being colored.
Also, I used colorindex > 0 as the condition for having color filling.
a = 0
If .Range("B7").Interior.ColorIndex > 0 Then
a = 1
End If
If .Range("B8").Interior.ColorIndex > 0 Then
a = a + 1
End If
If .Range("B9").Interior.ColorIndex > 0 Then
a = a + 1
End If
If a = 2 Then
.Range("B10").Interior.ColorIndex = 3
ElseIf a = 1 Then
.Range("B10").Interior.ColorIndex = 43
End If
Related
I have a list of 1000+ names in a single column in excel where the names repeat occasionally. I am trying to count how many times each name occurs. This is what I have currently and it populates the desired sheet but it seems to mess up when counting the number of times the names show up. Anything helps!
m = 2
n = 1
person = Worksheets("Sheet1").Cells(m, 6).Value
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
For i = 0 To Total_Tickets
person = Worksheets("Sheet1").Cells(m, 6).Value
y = 1
d = 0
Do While d <= i
comp = Worksheets("Sorted_Data").Cells(y, 2).Value
x = StrComp(person, comp, vbTextCompare)
If x = 0 Then
Worksheets("Sorted_Data").Cells(n - 1, 3).Value = Worksheets("Sorted_Data").Cells(n - 1, 3).Value + 1
m = m + 1
d = 10000
ElseIf x = 1 Or x = -1 Then
If comp = "" Then
Worksheets("Sorted_Data").Cells(n, 2).Value = person
Worksheets("Sorted_Data").Cells(n, 3).Value = 1
n = n + 1
m = m + 1
d = 10000
End If
y = y + 1
d = d + 1
End If
Loop
Next i
You're managing a lot of counters there, and that makes the logic more difficult to follow.
You could consider something like this instead:
Sub Tester()
Dim wsData As Worksheet, wsList As Worksheet, arr, m, i As Long, nm
Set wsData = ThisWorkbook.Sheets("Sheet1")
Set wsList = ThisWorkbook.Sheets("Sorted_Data")
'grab all the names in an array
arr = wsData.Range("A2:A" & wsData.Cells(Rows.Count, "A").End(xlUp).Row).Value
For i = 1 To UBound(arr, 1) 'loop over the array
nm = arr(i, 1) 'grab the name
m = Application.Match(nm, wsList.Columns("A"), 0) 'existing name on the summary sheet?
If IsError(m) Then
'name was not found: add it to the summary sheet
With wsList.Cells(Rows.Count, "A").End(xlUp).Offset(1)
.Value = nm
m = .Row
End With
End If
With wsList.Cells(m, "B")
.Value = .Value + 1 'update the count
End With
Next i
End Sub
I need to build a list of superscripts in a document which is fine until I get to symbols for things like partial derivatives which instead return as ? in my array instead of ∂. What could I add to capture the actual symbol? Thanks
Dim i As Long, j As String
Dim txtboxString() As String
Dim Superscript As String
Dim myrange As range
Dim ap As Document: Set ap = ActiveDocument
x = 0
For i = 1 To ap.Characters.Count
j = ""
If ActiveDocument.Characters(i).Font.Superscript = True Then
Z = 0
ReDim Preserve txtboxString(x + 1)
For Z = i To i - 5 Step -1
If Z > ap.Characters.Count Then GoTo 1
If ActiveDocument.Characters(Z) = "," Then GoTo 0
If ActiveDocument.Characters(Z).Font.Superscript = True Then j = ActiveDocument.Characters(Z) & j
Next Z
End If
0: If j <> "" Then
If j <> "," Then
If j <> "?" Then
txtboxString(x) = j
x = x + 1
End If
End If
End If
If Z + 1 > ap.Characters.Count Then i = Z 'Else i = Z + 1
Set myrange = ActiveDocument.Characters(i + 1)
myrange.MoveUntil Cset:="* "
i = myrange.End - 1
Next
so I am getting errors for some reason "next without for"
here is the code:
Sub test()
Dim y As Integer
y = 0
For i = 1 To 7
For j = 1 To 7
If Cells(i, 1) = Cells(j, 1) Then
y = y + 1
Next j
Cells(i, 2).Value = y
y = 0
Next i
End Sub
The problem doesn't come from your For ... To ... Next but from your If condition that you forgot to close with the End If instruction.
Sub test()
Dim y As Integer
y = 0
For i = 1 To 7
For j = 1 To 7
If Cells(i, 1) = Cells(j, 1) Then
y = y + 1
End If 'You forgot to end the condition
Next j
Cells(i, 2).Value = y
y = 0
Next i
End Sub
I have a program Sub which works well. I want to convert it into a custom Function, but when I use this function in Excel an error (#VALUE!) occurs
Function ТридцатьТРи(Diapozon As Integer)
'для п/пр
Dim k, n As Integer
Dim parRange As Range
Set parRange = Range("Diapozon")
k = 0
n = 0
For Each Cell In parRange.Rows
If Cell.Offset(0, 1).Value = 1 And k = -1 Then
n = n - 1
End If
If Cell.Value = 1 And k = -1 Then
n = n + 1
End If
If Cell.Value = 1 Then
k = k + 1
If k = 2 Then
k = -1
End If
End If
If Cell.Value = 2 Or Cell.Value = 3 Then
k = 0
End If
Next Cell
ТридцатьТРи = n
End Function
Try the UDF code below (not sure about what you are trying to achieve with your logics inside the UDF), but it works (not getting #VALUE!).
Since you want to pass a Range object to the UDF (according to your screen-shot), you need to define it also in your Function code.
Code
Function cyrilic(Diapozon As Range) As Long
Dim k As Long, n As Long
Dim C As Range
k = 0
n = 0
For Each C In Diapozon.Rows
If C.Offset(0, 1).Value = 1 And k = -1 Then
n = n - 1
End If
If C.Value = 1 And k = -1 Then
n = n + 1
End If
If C.Value = 1 Then
k = k + 1
If k = 2 Then
k = -1
End If
End If
If C.Value = 2 Or C.Value = 3 Then
k = 0
End If
Next C
cyrilic = n
End Function
This will work as a worksheet function apperently, you need to input the range that you previousely defined with a named range "diapozon" as an input range.
Function cyrillic(rng As Range)
Dim k, n As Integer
Dim parRange As Range
Set parRange = rng
k = 0
n = 0
For Each Cell In parRange.Rows
If Cell.Offset(0, 1).Value = 1 And k = -1 Then
n = n - 1
End If
If Cell.Value = 1 And k = -1 Then
n = n + 1
End If
If Cell.Value = 1 Then
k = k + 1
If k = 2 Then
k = -1
End If
End If
If Cell.Value = 2 Or Cell.Value = 3 Then
k = 0
End If
Next Cell
cyrillic = n
End Function
Just type : =cyrillic("R1:RX") and it should work.
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