I'm trying to code an analysis that will count certain cells in a data set and color code them based on their relative values. I have the counter code finished, but am now trying to get a subprocedure for the coloring to work. I've been able to achieve this in a stand alone sub procedure that has a manually entered range (ie "b2:e44") however, this isn't super useful as I will be applying this code to many datasets that vary in size.
I was able to code into the function a variable range called "datarange" that changes based on the entered datarange, but when I try to call the datarange and max variables into the subprocedure, it doesn't work.
How do I continue using the function variables in the subprocedure?
This is what I have so far:
Function breadthreport(datarange As Range, max As Variant, increase As String)
'counters
Dim cf1 As Variant
cf1 = 0
Dim cf2 As Variant
cf2 = 0
Dim cf3 As Variant
cf3 = 0
Dim cf4 As Variant
cf4 = 0
'cell variables
Dim x As Variant
Dim y As Variant
'no room for improvement
For x = 1 To datarange.Rows.Count Step 2
For y = 1 To datarange.Columns.Count
If datarange(x, y) = datarange(x + 1, y) And datarange(x, y) = max Then
cf1 = cf1 + 1
Else
End If
Next y
Next x
'stagnant cohort
For x = 1 To datarange.Rows.Count Step 2
For y = 1 To datarange.Columns.Count
If datarange(x, y) = datarange(x + 1, y) Then
cf2 = cf2 + 1
Else
End If
Next y
Next x
'worsening cohorts
For x = 1 To datarange.Rows.Count Step 2
For y = 1 To datarange.Columns.Count
If increase = "improvement" Then
If datarange(x, y) > datarange(x + 1, y) Then
cf3 = cf3 + 1
Else
End If
ElseIf increase = "worsening" Then
If datarange(x, y) < datarange(x + 1, y) Then
cf3 = cf3 + 1
Else
End If
Else
End If
Next y
Next x
'success cohorts
For x = 1 To datarange.Rows.Count Step 2
For y = 1 To datarange.Columns.Count
If increase = "improvement" Then
If datarange(x, y) < datarange(x + 1, y) Then
cf4 = cf4 + 1
Else
End If
ElseIf increase = "worsening" Then
If datarange(x, y) > datarange(x + 1, y) Then
cf4 = cf4 + 1
Else
End If
Else
End If
Next y
Next x
'define your array
Dim ret(3, 1) As Variant
Dim labels(3, 0) As String
'insert a sub to color the labels
breadthcolor datarange, max, increase
'labels
ret(0, 0) = "Stagnant Max Cohort"
ret(1, 0) = "Stagnant Cohort"
ret(2, 0) = "Worsening Cohort"
ret(3, 0) = "Success Cohort"
'assign values
ret(0, 1) = cf1
ret(1, 1) = cf2
ret(2, 1) = cf3
ret(3, 1) = cf4
breadthreport = ret
End Function
Sub breadthcolor(subrange As Range, submax As Variant, subincrease As String)
MsgBox "youre in the sub"
'cell variables
Dim x As Variant
Dim y As Variant
'no room for improvement
For x = 1 To subrange.Rows.Count Step 2
For y = 1 To subrange.Columns.Count
For Each cell In subrange
If cell(x, y).Value = cell(x + 1, y).Value Then
cell.Interior.color = vbGreen
Else
End If
Next
Next y
Next x
'the rest of the sub will mirror the counter function but with color changes rather than counters
End Sub
Ideally this can be done using the datarange defined in the function, I'm sharing this code with my team who have no background in coding and will not be able to manually edit the range in the procedure.
Related
This code copies the entire row to another when the word 'ordered' is in a certain column.
However, I need to adapt this code to not copy the entire row for another function but requires only copying columns A:J over into the next sheet but I'm having difficulty achieving this.
Sub MovingOrderedItems()
Dim xRg As Range
Dim xCell As Range
Dim X As Long
Dim Y As Long
Dim Z As Long
X = Worksheets("Engineer-Items to be ordered").UsedRange.Rows.Count
Y = Worksheets("Admin").UsedRange.Rows.Count
If Y = 1 Then
If Application.WorksheetFunction.CountA(Worksheets("Admin").UsedRange) = 0 Then Y = 0
End If
Set xRg = Worksheets("Engineer-Items to be ordered").Range("N3:N" & X)
On Error Resume Next
Application.ScreenUpdating = False
For Z = 1 To xRg.Count
If CStr(xRg(Z).Value) = "ordered" Then
xRg(Z).EntireRow.Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
xRg(Z).EntireRow.Delete
If CStr(xRg(Z).Value) = "ordered" Then
Z = Z - 1
End If
Y = Y + 1
End If
Next
Application.ScreenUpdating = True
End Sub
There's probably a more elegant way to do this, but you can replace
xRg(Z).EntireRow.Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
With
Range(xRg(Z).EntireRow.Cells(1, 1), xRg(Z).EntireRow.Cells(1, 10)).Copy Destination:=Worksheets("Admin").Range("A" & Y + 1)
I'm trying to create a page index of one worksheet, which has about 1500 rows to trace back the information. My idea is to build up either a function or a code block to realize this function. Unfortunately, both don't work. The code I add to my programm is written by Allen Wyatt (https://excelribbon.tips.net/T011581_Page_Numbers_in_VBA.html). It works if the pagenumber is shown with MsgBox. I want either, it works as a function, with that I get the pagenumber of a random cell (just to enter the cell address of this worksheet) or to integrate it into my loop programm to fill the index with page numbers.
I don't understand why the both methodes don't work. As fuction it only shows invalid value. As the value to loop the chaptern numbers, I only get the page number as 1.
Can any guru explain to me the reason?
Thanks a lot!
1.Function:
Public Function showpagenumber() As Integer
Dim iPages As Integer
Dim iCol As Integer
Dim iCols As Integer
Dim lRows As Long
Dim lRow As Long
Dim x As Long
Dim y As Long
Dim iPage As Integer
iPages = ExecuteExcel4Macro("Get.Document(50)")
With ActiveSheet
y = ActiveCell.Column
iCols = .VPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = iCols _
Or y < .VPageBreaks(x).Location.Column
iCol = x
If y >= .VPageBreaks(x).Location.Column Then
iCol = iCol + 1
End If
y = ActiveCell.Row
lRows = .HPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = lRows _
Or y < .HPageBreaks(x).Location.Row
lRow = x
If y >= .HPageBreaks(x).Location.Row Then
lRow = lRow + 1
End If
If .PageSetup.Order = xlDownThenOver Then
iPage = (iCol - 1) * (lRows + 1) + lRow
Else
iPage = (lRow - 1) * (iCols + 1) + iCol
End If
End With
showpagenumber = iPage
End Function
Code in programm, with that I only get the page number 1.
...
For i = chapterstart To chapterend
emptyrow = WorksheetFunction.CountA(ws2.Range("D:D")) + 1
If Not IsEmpty(ws1.Cells(i, "A")) And IsNumeric(ws1.Cells(i, "A")) Then
iPages = ExecuteExcel4Macro("Get.Document(50)")
With ws1
y = ActiveCell.Column
iCols = .VPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = iCols _
Or y < .VPageBreaks(x).Location.Column
iCol = x
If y >= .VPageBreaks(x).Location.Column Then
iCol = iCol + 1
End If
y = ActiveCell.Row
lRows = .HPageBreaks.Count
x = 0
Do
x = x + 1
Loop Until x = lRows _
Or y < .HPageBreaks(x).Location.Row
lRow = x
If y >= .HPageBreaks(x).Location.Row Then
lRow = lRow + 1
End If
If .PageSetup.Order = xlDownThenOver Then
iPage = (iCol - 1) * (lRows + 1) + lRow
Else
iPage = (lRow - 1) * (iCols + 1) + iCol
End If
End With
ws2.Cells(emptyrow, "D").Value = iPage
End If
Next
I've been toying with this very simple code and am completely baffled. Below are three different variations I have tried in order to figure out the issue and none have worked.
Original Code:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) = RADAR.Cells(x, 1) And UTDT.Cells(i, 25) <> RADAR.Cells(x, 2) Then
Result.Cells(y, 1) = Trim(UTDT.Cells(i, 1))
Result.Cells(y, 2) = UTDT.Cells(i, 2)
Result.Cells(y, 3) = UTDT.Cells(i, 3)
Result.Cells(y, 4) = "Update"
End If
Next y
Next i
Next x
End Sub
I then remove the and portion and added a message box to simplify it:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) = RADAR.Cells(x, 1) Then
MsgBox ("It WORKED!")
End If
Next y
Next i
Next x
End Sub
Still skips the IF statement. So i decided ill change it to <> in case its skipping because invisible formatting is causing it to be false.. but still no luck:
Sub GetResults()
Set Result = ActiveWorkbook.Worksheets("Results")
Set UTDT = ActiveWorkbook.Worksheets("UTDT")
Set RADAR = ActiveWorkbook.Worksheets("RADAR")
Dim y As Long
Dim i As Long
Dim x As Long
For x = 2 To RADAR.UsedRange.Rows.Count
For i = 2 To UTDT.UsedRange.Rows.Count
For y = 2 To Result.UsedRange.Rows.Count
If UTDT.Cells(i, 1) <> RADAR.Cells(x, 1) Then
MsgBox ("It WORKED!")
End If
Next y
Next i
Next x
End Sub
I am trying to interpolate a value in the table. However since my column cells are merged together, my code won't read the values. So far whenever i unmerge those columns, it works completely fine and gives me the value i want. How do i integrate merged cells as a matrices?
Sub brent()
Dim i As Integer, j As Integer
Dim P As Single, P1 As Single, P2 As Single
Dim M As Single, M1 As Single, M2 As Single
Dim inputmat()
nrow = 29
ncol = 2
P = Range("Axial").Value
ReDim inputmat(nrow, ncol)
For i = 1 To nrow
For j = 1 To ncol
inputmat(i, j) = Cells(5 + i, 6 + j)
Next j
Next i
If (P > inputmat(1, 1)) Or (P < inputmat(nrow, 1)) Then Range("PM").Value =
"NG"
Else
For i = 1 To nrow - 1
If (P <= inputmat(i, 1)) And (P >= inputmat(i + 1, 1)) Then
P1 = inputmat(i, 1)
P2 = inputmat(i + 1, 1)
M1 = inputmat(i, 2)
M2 = inputmat(i + 1, 2)
End If
Next i
For i = 1 To nrow
M = M1 + (P - P1) * (M2 - M1) / (P2 - P1)
Next i
Range("PM").Value = M
End If
End Sub
I know that there is problem under the "input (i,j)= cells(5+i,6+j)"
Is there any way to read that black column between the merged cells?
Sub FindMergedCells()
Dim tbl As Range, cll As Range
Dim i As Integer
i = 1
Set tbl = Range("A1:E4")
For Each cll In tbl
If cll.MergeCells Then
Cells(i, 7) = "Cell " & cll.Address & " is merged"
i = i + 1
End If
Next
End Sub
using excel VBA i have to generate a table of numbers counting anti clock wise with one in the middle and highlight prime numbers in red in the process the following image is an example of the out put i should have .
Thanks to you guys i have used the above code to come up with this code which works perfectly.
Option Explicit
Private Function GetPrime(MaxToCheck As Long) As Collection
Dim c As New Collection, isUnDivided As Boolean, i As Long, v
c.Add Key:="2", Item:=2
For i = 3 To MaxToCheck
isUnDivided = True
For Each v In c
If i Mod v = 0 Then isUnDivided = False: Exit For
Next v
If isUnDivided Then c.Add Key:=CStr(i), Item:=i
Next i
Set GetPrime = c
End Function
Sub prime()
Dim a, c As New Collection, i As Long, j As Long, r As Range, v
With Range("A1").CurrentRegion
a = .Value
Set c = GetPrime(Application.Max(a))
For i = 1 To UBound(a, 1)
For j = 1 To UBound(a, 2)
On Error Resume Next
v = c(CStr(a(i, j)))
If Err.Number = 0 Then
If Not r Is Nothing Then Set r = Union(r, .Cells(i, j)) Else
Set r = .Cells(i, j)
End If
On Error GoTo 0
Next j
Next i
End With
If Not r Is Nothing Then r.Font.Color = vbRed
End Sub
Here is a sample code for you to start with,
Sub primeNum()
Dim i As Long, j As Long, k As Long, x As Long, y As Long, z As Long
Dim l As Long
j = 50
x = 20
y = 20
k = 1
i = 1
Cells(x, y) = 1
Loops:
For z = 1 To 4
If z = 3 Then
k = k + 1
End If
For l = 1 To k
i = i + 1
Select Case (z)
Case "1":
y = y + 1
Cells(x, y) = i
Case "2":
x = x - 1
Cells(x, y) = i
Case "3":
y = y - 1
Cells(x, y) = i
Case "4":
x = x + 1
Cells(x, y) = i
End Select
Next l
Next z
k = k + 1
If i <= j Then
GoTo Loops
End If
End Sub
I leave the part of checking prime numbers for you to google and find,