I have an algorithm in code of userform that I'm using to add names of months to a VBA userform dynamically. I want to add the months 3 times as an header for 3 different categories. My problem is that in the Algorithm I created the space between the two first months is one and between the second month and the third the space is double. the months values is in worksheet 8 in the cells A4 to A7.
it looks like this in the uFebruary
december ___January ______February
Here is my code:
'months in commission, workdays and workhours
Dim m As Integer 'm = month
Dim T As Integer 'T=TOP
Dim L As Integer 'L= loop
T = 50
For m = 1 To 3
For L = 1 To 9
DATA = ThisWorkbook.Worksheets(8).Range("A" & m + 3).Value
Set dLbl = UserForm1.Controls.Add("Forms.Label.1", "dLbl", True)
With dLbl
.Top = 70
If L < 4 Then
.Left = 700 - (T * m)
ElseIf L > 6 Then
.Left = 190 - (T * m)
Else
.Left = 450 - (T * m)
End If
.Height = 50
.Caption = DATA
.Font.Bold = True
.Font.Size = 11
.Width = 45
.TextAlign = fmTextAlignRight
End With
Next L
Next m
Related
I am getting the "next without for" error. I checked other questions on this and looked for any open if statements or loops in my code, but could find none. I'm need an extra set of eyes to catch my error here.
I am trying to loop through this code and advance the torque value 3 times each times it gets to the 30th i.
'This is Holzer's method for finding the torsional natural frequency
Option Explicit
Sub TorsionalVibrationAnalysis_()
Dim n As Integer 'position along stucture
Dim m As Integer
Dim i As Long 'frequency to be used
Dim j As Variant 'moment of inertia
Dim k As Variant 'stiffness
Dim theta As Long 'angular displacement
Dim torque As ListRow 'torque
Dim lambda As Long 'ListRow 'omega^2
Dim w As Variant
Dim s As Long
'equations relating the displacement and torque
n = 1
Set j = Range("d2:f2").Value 'Range("d2:f2").Value
Set k = Range("d3:f3").Value
'initial value
Set w = Range("B1:B30").Value
For i = 1 To 30
'start at 40 and increment frequency by 20
w = 40 + (i - 1) * 20
lambda = w ^ 2
theta = 1
s = 1
Do While i = 30 & s <= 3
torque = lambda * j(1, s)
s = s + 1
End
m = n + 1
theta = theta - torque(i, n) / k(n)
torque(i, m) = torque(i, n) + lambda * j(m) * theta
If m = 4 & i < 30 Then
w(i) = 40 + (i - 1) * 20
lambda = w(i) ^ 2
ElseIf m = 4 & i >= 30 Then
Cells([d], [5+i]).display (i)
Cells([e], [5+i]).display (theta)
Cells([f], [5+i]).display (torque)
Else
End If
If m <> 4 Then
n = n + 1
End If
Next i
End Sub
You are trying to terminate your While with an End instead of Loop
Try changing your End to Loop in your Do While loop. I think you are terming the loop when you hit that End
Proper indentation makes the problem rather apparent.
You have:
For i = 1 To 30
'...
Do While i = 30 & s <= 3
'...
End
'...
If m = 4 & i < 30 Then
'...
ElseIf m = 4 & i >= 30 Then
'...
Else
End If
If m <> 4 Then
'...
End If
Next i
But run it through Rubberduck's Smart Indenter and you get:
For i = 1 To 30
'...
Do While i = 30 & s <= 3
'...
End
'...
If m = 4 & i < 30 Then
'...
ElseIf m = 4 & i >= 30 Then
'...
Else
End If
If m <> 4 Then
'...
End If
Next i
End Sub
Notice how the End other answers are pointing out, is clearly not delimiting the Do While loop.
The Next i is inside the Do While block, which isn't terminated - when the VBA compiler encounters that Next i, it doesn't know how it could possibly relate to any previously encountered For statement, and thus issues a "Next without For" compile error.
Use an indenter.
First time poster!
I am hoping someone can help with my a VBA code. I have some experience with VBA coding, but I don't have the knowledge or expertise to handle the task I am facing.
I have a report of entities and their owners.
With this report, you can follow the ownership chain of each entity.
Here is an example of the Report:
Entity #, Entity Name, Parent #, Parent Name, Owner % Inside
100 Entity 1 200 Entity2 100 Yes
200 Entity 2 300 Entity 3 50 Yes
200 Entity 2 400 Entity 4 50 Yes
500 Entity 5 600 Entity 6 100 Yes
600 Entity 6 700 Entity 7 25 Yes
600 Entity 6 800 Entity 8 25 Yes
600 Entity 6 900 Entity 9 50 Yes
800 Entity 8 1200 Entity 12 100 Yes
900 Entity 9 1000 Entity 10 25 No
900 Entity 9 1100 Entity 11 75 Yes
So basically, Entity one is owned 100% by Entity 2. Entity 2 is owned by 50% by Entity 4 and Entity 5. Entity 3 and 4 is not owned by any affiliates. Entity 5 is owned 100% by Entity 6. Entity 6 is owned 25% to Entity 7, 25% by entity 8 and 50% by entity 9 . Entity 8 is owned 100% by entity 12. Entity 9 is owned 25% by entity 10 and 75% by Entity 11. Entity 10 is not an affiliate.
The code should calculate the Pick-up % of the lower entity [100 & 500]. In this case, the Pick-up % for 100 will be 100% because all of the entities in the chain are affiliates. While the pick-up% for 500 is 75% because entity 1000 is not an affiliate.
I have started and stop writing this code at least ten times and each time I get stuck along the way. Here is my issue: In reality, the chain could go up 7 to 8 levels. Once I get back past level two, I do not know how to calculate the pickup % of the entity has multiple owners. For instance, if you look at my table up top. Once I calculate the ownership for 600, I can't figure how to extend the chain to owners of 800 and 900.
Here is a diagram of the ownership structures:
Here is the code I have so far:
Sub ownerinterest()
Sheets("Copyii").Activate
Set dict3 = New Dictionary
nRowCount = Cells(Rows.Count, "B").End(xlUp).Row
arowcount = Cells(Rows.Count, "AA").End(xlUp).Row
ReportArray = Range(Cells(1, "AA"), Cells(arowcount, "AB"))
For i = 2 To nRowCount
GemC = Left(Cells(i, "a"), 5)
ParentC = Cells(i, "d")
PctC = (Cells(i, "J") / 100)
OwnerC = Cells(i, "h")
EntityC = Cells(i, "b")
d = i
If (Not (dict3.Exists(GemC))) Then
Set GEMclass = New Gclass
dict3.Add GemC, GEMclass
dict3(GemC).e = EntityC
dict3(GemC).P = ParentC
dict3(GemC).O = OwnerC
dict3(GemC).Num = d
dict3(GemC).g = GemC
End If
Call countlevels
dict3(GemC).Pct = PctC
Next i
Call Calculepickup
End Sub
Sub countlevels()
For e = LBound(ReportArray, 1) To UBound(ReportArray, 1)
If GemC = ReportArray(e, 1) Then
If ReportArray(e, 2) > 1 Then
Pcount = ReportArray(e, 2)
PctC = 0
For f = 1 To Pcount
TPct = Cells(i + f - 1, "J")
PctC = TPct + PctC
Next f
Exit For
Else
PctC = PctC
Exit For
End If
End If
Next e
End Sub
Sub Calculepickup()
Dim g As Long, h As Integer, j As Integer, m As Integer
Dim NewGem As String
Dim Tpct2 As Double
Dim MainArray() As Variant
Dim MainRange As Range
m = Cells(Rows.Count, "A").End(xlUp).Row
Set MainRange = Range("a1:J" & m)
MainArray() = MainRange
For g = 0 To dict3.Count - 1
Set GEMclass = dict3.Items(g)
ReportGEM = GEMclass.P
GemC = GEMclass.g
PctC = GEMclass.Pct
Debug.Print GemC & "|" & ReportGEM & "|" & PctC
For h = 0 To dict3.Count - 1
If (dict3.Exists(ReportGEM)) Then
NewGem = ReportGEM
For j = LBound(ReportArray) To UBound(ReportArray)
If NewGem = ReportArray(j, 1) Then
If ReportArray(j, 2) > 1 Then
Pcount = 0
Pcount = ReportArray(j, 2)
Tpct2 = 0
Dim K As Integer
For K = LBound(MainArray, 1) To UBound(MainArray, 1)
Dim GEMk As String
GEMk = MainArray(K, 1)
If NewGem = GEMk Then
Debug.Print GEMk & "|" & K
For f = 1 To Pcount
TPct = Cells(K + f - 1, "J")
Debug.Print TPct
Tpct2 = TPct + Tpct2
Debug.Print Tpct2
Next f
Exit For
End If
Next K
End If
End If
Next j
End If
Next h
Next g
End Sub
I believe that the following will do what you want. (It's probably the only real way to associate an "ownership percentage" based on multiple parents each with their own "ownership percentage".)
Public entities As New Dictionary
Public MainArray() As Variant
'I have assumed that the table you posted in the question represented columns A to F of an Excel spreadsheet.
'Change the following constants so it suits your actual layout.
Const colEntity As Integer = 1 ' Assumed column A
Const colParent As Integer = 3 ' Assumed column C
Const colPct As Integer = 5 ' Assumed column E
Const colInside As Integer = 6 ' Assumed column F
Sub Calculepickup()
Dim g As Integer, r As Integer, m As Integer
Dim MainRange As Range
m = Cells(Rows.Count, "A").End(xlUp).Row
Set MainRange = Range("a2:J" & m)
MainArray() = MainRange
'Add each entity to a dictionary, and flag the percentage as uncalculated by setting it to -1
For g = 1 To UBound(MainArray, 1)
If Not entities.Exists(MainArray(g, colEntity)) Then
entities.Add MainArray(g, colEntity), -1
End If
If Not entities.Exists(MainArray(g, colParent)) Then
If MainArray(g, colInside) = "No" Then
'If the entity isn't "inside" store the fact that it is 0% owned
entities.Add MainArray(g, colParent), 0
Else
entities.Add MainArray(g, colParent), -1
End If
End If
Next
r = 0
For Each e In entities.Keys
CalculatePct e
'Write results to columns N and O just so that we can see them
r = r + 1
Cells(r, 14) = e
Cells(r, 15) = entities(e)
Next
End Sub
Sub CalculatePct(e As Variant)
Dim g As Integer
Dim pct As Double
Dim Owned100Pct As Boolean
If entities(e) < 0 Then
pct = 0
Owned100Pct = True ' Keeps track if the entity exists in the table other than as a parent
For g = 1 To UBound(MainArray, 1)
If MainArray(g, colEntity) = e Then
Owned100Pct = False
If entities(MainArray(g, colParent)) = -1 Then
'If we don't know the parent's ownership percentage, go and calculate it
CalculatePct MainArray(g, colParent)
End If
pct = pct + CDbl(MainArray(g, colPct)) / 100 * entities(MainArray(g, colParent))
End If
Next
If Owned100Pct Then
'Assume 100% owned if we don't know the parentage
'("Outside" entities won't go through here as they are already set to 0%)
entities(e) = 1
Else
'Store the entity's percentage
entities(e) = pct
End If
End If
End Sub
So, I made a fun and simple macro that randomly selects R, G, and B values until it uses every possible combination (skipping repeats), and setting the color values of a 10x10 square with each new color.
The only problem is that I have run into the limit for the number of cell formats. Microsoft says that the limit should be around 64000, but I found it to be exactly 65429 on a blank workbook in Excel 2013.
I've included a clear format code, but it seems to have no effect:
Cells(X, Y).ClearFormats
Microsoft lists some resolutions, but 3 out of the 4 of them are essentially "Don't make too many formats", and the 4th format is to use a third party application.
Is there really nothing that can be done in VBA?
A1:J10 will print a new color
K1 will print the percentage to completion
L1 will print the number of colors used
M1 will print the number of times a color combination is repeated
Dim CA(255, 255, 255) As Integer
Dim CC As Long
Dim RC As Long
Dim R As Integer
Dim G As Integer
Dim B As Integer
Dim X As Integer
Dim Y As Integer
CC = 0
RC = 0
X = 1
Y = 1
Do While ColorCount < 16777216
R = ((Rnd * 256) - 0.5)
G = ((Rnd * 256) - 0.5)
B = ((Rnd * 256) - 0.5)
If CA(R, G, B) <> 1 Then
CA(R, G, B) = 1
'Step down to the next row
'If at the 10th row, jump back to the first and move to the next column
If X < 10 Then
X = X + 1
Else
X = 1
If Y < 10 Then
Y = Y + 1
Else
Y = 1
End If
End If
Cells(X, Y).ClearFormats 'doesn't do what I hope :(
Cells(X, Y).Interior.Color = RGB(R, G, B)
CC = CC + 1
Cells(1, 11).Value = (CC / 16777216) * 100
Cells(1, 12).Value = CC
Else
RC = RC + 1
Cells(1, 13).Value = RC
End If
Loop
There are several ways to resolve this issue, but the cleanest and easiest method is to remove all extra styles (I have seen workbooks with 9000+ styles )
With the following simple VBA code you can remove all non-builtin styles and in the vast majority of cases this fixes the error.
Sub removeStyles()
Dim li as long
On Error Resume Next
With ActiveWorkbook
For li = .Styles.Count To 1 Step -1
If Not .Styles(li).BuiltIn Then
.Styles(li).Delete
End If
Next
End With
End Sub
NET developers.
I'm trying to put 20 labels on a form and place them line by line (I do this by the .Top method). I am sure there is a way I can program declaring and formatting by looping through more general code 20 times.
The below is what I've done for the first label.
Thanks in advance for help!
Dim Label1 As New Label
Me.Controls.Add(Label1)
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
With Label1
.Width = 512
.Height = 18
.Top = subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6
.Left = 12
.Text = "label" & m
End With
Next
You should place this as the first line inside your loop:
Dim Label1 As New Label
And this as the last line insde your loop:
Me.Controls.Add(Label1)
Example 1
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
Dim Label1 As New Label
With Label1
.Width = 512
.Height = 18
.Top = subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6
.Left = 12
.Text = "label" & m
End With
Me.Controls.Add(Label1)
Next
Example 2
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
Me.Controls.Add(New Label() With {.Width = 512, .Height = 18, .Top = (subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6), .Left = 12, .Text = ("label" & m)})
Next
you can use your code by place declare statement inside loop
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
Dim Label1 As New Label
With Label1
.Width = 512
.Height = 18
.Top = subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6
.Left = 12
.Text = "label" & m
End With
Me.Controls.Add(Label1)
Next
or use panel just like this but you have to place declare statement inside loop
or should make label array for future reference by
Dim label(yoursize) As Label
For m = 1 To OutlookManager3.GlobalVariables.SelectedAppointmentsNo
label(m) = new label
label(m).ID="future referece id"
With Label1
.Width = 512
.Height = 18
.Top = subject.Top + subject.Height + m * 6 + (m - 1) * 18 + (m - 1) * 6
.Left = 12
.Text = "label" & m
End With
by this you can use that next time
Me.Controls.Add(Label1)
Next
I am new to VBA. I am trying to run a formatting check on a sheet.
The error is Next without For error. What I am trying to do is to check columns H and O from rows number 33 to 58 for number formatting error. It shows error at "Next n".
The code is like this:
Public Sub PercentageCheck()
Dim CTRYname As String
Dim x As Integer
Dim n As Integer
Dim m As Integer
For n = 1 To 13
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
For m = 33 To 58
For x = 8 To 15
If x = 9 Or x = 10 Or x = 11 Or x = 12 Or x = 13 Or x = 14 Then
GoTo Names
Else
wkbCurr.Sheets(CTRYname).Activate
If IsNumeric(wkbCurr.Sheets(CTRYname).Cells(x, m).Value) Then
If wkbCurr.Sheets(CTRYname).Cells(x, m).Value > 9.99 Then
wkbCurr.Sheets(CTRYname).Cells(x, m).Value = ">999%"
ElseIf wkbCurr.Sheets(CTRYname).Cells(x, m).Value < -9.99 Then
wkbCurr.Sheets(CTRYname).Cells(x, m).Value = "<-999%"
End If
End If
Names:
Next x
Next m
Next n
End Sub
Can you help with suggestions for a better way to check it.
Second question first: suggest a better way to check it.
Answer: be diligent with indenting. This easily revleals the missing line of code
Public Sub PercentageCheck()
Dim CTRYname As String
Dim x As Integer
Dim n As Integer
Dim m As Integer
For n = 1 To 13
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
For m = 33 To 58
For x = 8 To 15
If x = 9 Or x = 10 Or x = 11 Or x = 12 Or x = 13 Or x = 14 Then
GoTo Names
Else
wkbCurr.Sheets(CTRYname).Activate
If IsNumeric(wkbCurr.Sheets(CTRYname).Cells(x, m).Value) Then
If wkbCurr.Sheets(CTRYname).Cells(x, m).Value > 9.99 Then
wkbCurr.Sheets(CTRYname).Cells(x, m).Value = ">999%"
ElseIf wkbCurr.Sheets(CTRYname).Cells(x, m).Value < -9.99 Then
wkbCurr.Sheets(CTRYname).Cells(x, m).Value = "<-999%"
End If
End If
' ---> Missing End If
Names:
Next x
Next m
Next n
End Sub
BTW, the GoTo Names is not necassary in this code. And neither is wkbCurr.Sheets(CTRYname).Activate. Just leave them out and the code works the same.
Update:
Based on your comment and the bug it revealed, I suggest you use more meaningful variable names. This will help avoid this kind of error. Also, prudent use of With can make your code more readable (and faster)
Here's a refactored version to demonstrate
Public Sub PercentageCheck()
Dim CTRYname As String
Dim col As Integer
Dim n As Integer
Dim rw As Integer
For n = 1 To 13
CTRYname = ThisWorkbook.Sheets("Country lookup").Range("A1").Offset(n, 0).Value
With wkbCurr.Sheets(CTRYname)
For rw = 33 To 58
For col = 8 To 15
If col < 9 Or col > 14 Then
With .Cells(rw, col)
If IsNumeric(.Value) Then
If .Value > 9.99 Then
.Value = ">999%"
ElseIf .Value < -9.99 Then
.Value = "<-999%"
End If
End If
End With
End If
Next col, rw
End With
Next n
End Sub
You're missing an END IF for your If x = 9 Or x = 10 Or x = 11 Or x = 12 Or x = 13 Or x = 14 Then ... Else ...
Indent your code to improve readability and this sort of thing will become somewhat self-evident. #chris-neilsen's example is excellent.
Counting opening statements, compared to closing statements will help at a pinch (and is what I did to debug your code in this instance).
Using an IDE that highlights corresponding start/end symbols would also help you (but I'm not sure what IDE's are available for VBA macros... if anything).