I want to revert the loop to 1 but only in .cmdTable(i).caption = txtPrefix.Text + Str(i) so the name + the number will revert back to 1 because every time a transact it will get the continues number of the loop
I want that Str(i) revert back to 1 on every time i click OK
For example i set the name of the table = TABLE + the number txtEndTable.Text = 5 it will loop from TABLE 1 to TABLE 5 for the second transaction name of the table = MARK + the number txtEndTable.Text = 5 it will generate MARK 6 to MARK 10. I want to get the MARK 1 to MARK 5 for second transaction
Any idea will do
Public Sub pAddMultipleTables()
Dim i As Integer
Dim x As Long
Dim lcDefaultTop As Integer
Dim lcLastLeft As Integer
Dim lcMax As Integer
Dim lcSpacing As Integer
Dim lcCurrentTable As Integer
Dim lcStart As Integer
lcSpacing = 1200
lcDefaultTop = 1300
lcMax = 5
lcCurrentTable = 1
lcLastLeft = 240
lcStart = 0
x = 0
With frmTableMap
For i = .cmdTable.ubound + 1 To .cmdTable.ubound + txtEndTable.Text
Load .cmdTable(i)
.cmdTable(i).Visible = True
If lcCurrentTable < lcMax Then
If lcCurrentTable = 1 Then
.cmdTable(i).Top = lcDefaultTop
Else
.cmdTable(i).Top = (.cmdTable(i - 1).Top + .cmdTable(i - 1).Height) + 120
End If
.cmdTable(i).Left = lcLastLeft
lcCurrentTable = lcCurrentTable + 1
' Add to database
.cmdTable(i).ZOrder 0
If optSquare.Value = True Then
.cmdTable(i).ButtonShape = 0
Else
.cmdTable(i).ButtonShape = 4
End If
.cmdTable(i).Caption = txtPrefix.Text + Str(i)
bRS.AddNew
bRS!Name = txtPrefix.Text + Str(i)
bRS!buttonorder = .cmdTable(i).Index
bRS!section = .lblSection.Caption
bRS!ForeColor = .cmdTable(i).ForeColor
bRS!FontSize = .cmdTable(i).Font.Size
bRS!Width = .cmdTable(i).Width
bRS!Height = .cmdTable(i).Height
bRS!Top = .cmdTable(i).Top
bRS!Left = .cmdTable(i).Left
bRS!FontBold = .cmdTable(i).Font.Bold
bRS!FontName = .cmdTable(i).Font.Name
bRS!BackColor = .cmdTable(i).BackColor
bRS!Capacity = txtCapacity.Text
bRS!Type = "1"
If optSquare.Value = True Then
bRS!ButtonShape = 0
Else
bRS!ButtonShape = 4
End If
bRS.Update
ElseIf lcCurrentTable = lcMax Then
If i > 1 Then
.cmdTable(i).Top = (.cmdTable(i - 1).Top + .cmdTable(i - 1).Height) + 200
.cmdTable(i).Left = lcLastLeft
End If
lcLastLeft = (lcLastLeft + .cmdTable(i).Width) + 120
lcCurrentTable = 1
.cmdTable(i).ZOrder 0
If optSquare.Value = True Then
.cmdTable(i).ButtonShape = 0
Else
.cmdTable(i).ButtonShape = 4
End If
.cmdTable(i).Caption = txtPrefix.Text + Str(i)
bRS.AddNew
bRS!Name = txtPrefix.Text + Str(i)
bRS!buttonorder = .cmdTable(i).Index
bRS!section = .lblSection.Caption
bRS!ForeColor = .cmdTable(i).ForeColor
bRS!FontSize = .cmdTable(i).Font.Size
bRS!Width = .cmdTable(i).Width
bRS!Height = .cmdTable(i).Height
bRS!Top = .cmdTable(i).Top
bRS!Left = .cmdTable(i).Left
bRS!FontBold = .cmdTable(i).Font.Bold
bRS!FontName = .cmdTable(i).Font.Name
bRS!BackColor = .cmdTable(i).BackColor
bRS!Capacity = txtCapacity.Text
bRS!Type = "1"
If optSquare.Value = True Then
bRS!ButtonShape = 0
Else
bRS!ButtonShape = 4
End If
bRS.Update
End If
Next
End With
End Sub
-Thanks guys
This might not be the most elegant solution but something like this might work.
For i = .cmdTable.lbound + 1 To .cmdTable.ubound + CInt(txtEndTable.Text)
https://msdn.microsoft.com/en-us/library/t9a7w1ac(v=vs.90).aspx
Related
im using console. ive written code its for my exam and im not very good at it but ive tried and no matter what i do i cant get the program to stop crashing. it keeps crashing at code 0 and im really frustrated please help me ive attached the code below
Module Module1
Sub Main()
Dim discount As Integer = 0
Dim freetickets As Integer = 0
Dim estimatedcost As Integer = 0
Dim totalstudents As Integer = 0
Dim coachcost As Integer = 550
Dim entryticket As Integer = 30
Dim name(45) As String
Dim paidstatus(45) As Boolean
Dim studentspaid As Integer = 0
Dim totalcost As Integer = 0
Dim collectedcost As Integer = 0
Dim finalcost As Integer = 0
Console.WriteLine("Enter Student Name")
name(45) = Console.ReadLine()
Console.WriteLine("has the student paid? (true/false)")
paidstatus(45) = Console.ReadLine()
If paidstatus(45) = True Then
studentspaid = studentspaid + 1
totalstudents = totalstudents + 1
ElseIf paidstatus(45) = False Then
totalstudents = totalstudents + 1
End If
totalcost = (totalstudents * 30) + (550 / totalstudents)
If totalstudents = 45 Then
If studentspaid = 10 Then
freetickets = freetickets + 1
End If
If studentspaid = 20 Then
freetickets = freetickets + 1
End If
If studentspaid = 30 Then
freetickets = freetickets + 1
End If
If studentspaid = 40 Then
freetickets = freetickets + 1
End If
collectedcost = (studentspaid * 30) + (550 / studentspaid)
discount = (freetickets * 30) - (550 / studentspaid)
finalcost = totalcost - collectedcost - discount
If finalcost > 0 Then
Console.WriteLine("loss of")
Console.WriteLine(-finalcost)
End If
If finalcost = 0 Then
Console.WriteLine("broken even")
End If
If finalcost < 0 Then
Console.WriteLine("profit of")
Console.WriteLine(finalcost)
End If
End If
End Sub
End Module
I am trying to simulate the I/O of this website page
My Input sheet looks like this:
Now after taking the values from input sheet and arranging them in ascending order I got this in a temp worksheet :
This is what my results sheet looks like:
Now I have tried this after sorting process(didn't add code for sorting since it's not the problem):
Set rng = Union(wTime.Range("D6:D25"), wTime.Range("F6:F25"), wTime.Range("H6:H25"), wTime.Range("J6:J25"))
cnt1 = 1: cnt2 = 1: cnt3 = 1: cnt4 = 1
wTime.Range("A6:A25") = Empty 'Ticker
For i = 1 To 20
bckStroke(i) = wTemp.Range("A" & i + 1).Value
brstStroke(i) = wTemp.Range("C" & i + 1).Value
btrFly(i) = wTemp.Range("E" & i + 1).Value
frStyle(i) = wTemp.Range("G" & i + 1).Value
wTime.Range("A6:A25") = Empty
For Each cel In rng
If cel.Column = 4 And cel.Value = bckStroke(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt1 < 6 Then
wRes.Cells((cnt1 + 5 + (cnt1 - 1) * 2) - 1, 4) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt1 + 5 + (cnt1 - 1) * 2, 4) = bckStroke(i) 'Time
cnt1 = cnt1 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 6 And cel.Value = brstStroke(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt2 < 6 Then
wRes.Cells((cnt2 + 5 + (cnt2 - 1) * 2) - 1, 6) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt2 + 5 + (cnt2 - 1) * 2, 6) = brstStroke(i) 'Time
cnt2 = cnt2 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 8 And cel.Value = btrFly(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt3 < 6 Then
wRes.Cells((cnt3 + 5 + (cnt3 - 1) * 2) - 1, 8) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt3 + 5 + (cnt3 - 1) * 2, 8) = btrFly(i) 'Time
cnt3 = cnt3 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
If cel.Column = 10 And cel.Value = frStyle(i) And cel.Value <> 0 And Trim(wTime.Cells(cel.Row, 1)) <> "Y" And cnt4 < 6 Then
wRes.Cells((cnt4 + 5 + (cnt4 - 1) * 2) - 1, 10) = wTime.Cells(cel.Row, 2) 'Athlete Name
wRes.Cells(cnt4 + 5 + (cnt4 - 1) * 2, 10) = frStyle(i) 'Time
cnt4 = cnt4 + 1
wTime.Cells(cel.Row, 1) = "Y"
End If
Next cel
Next i
I just want to know the simplest logic to get the desired result after arranging them in ascending order (refer temp sheet) it should be easy but I can't seem to understand it.
Conditions that I know of for now:
Each team should have unique swimmers (i.e 4 Unique names in each team)
A swimmer can appear in other team as well if he has best time in other category as well. (E.g. Marcelo will appear in top 4 team since he has the best time in all 4 categories)
Teams with shortest time should be placed 1st in the list on result sheet. I think sorting in ascending order takes care of this it's matter of selecting right swimmer from the temp sheet list.
EDIT:
4. Relay Logic premise: Get all the combinations possible without 2 identical strings. And then sort them lowest to largest. I'd do the following: Get all the possible combinations and their sum with the following: *Combinations may still be buggy, since it may be variable to how many numbers you may have. This is just a guide to describe the process
Sub Combinations()
Dim i As Long, j As Long, k As Long, l As Long, m As Long, n As Long, o As Long, p As Long, q As Long
Dim CountComb As Long, lastrow As Long
Range("K2").Value = Now - 5
Application.ScreenUpdating = False
CountComb = 0: lastrow = 6
For i = 1 To 6: For j = 1 To 5
For k = 1 To 6: For l = 1 To 6
If Not (i = j Or i = k Or i = l Or j = k Or j = l Or k = l) Then
Range("K" & lastrow).Value = Range("A" & i).Value & "/" & _
Range("B" & j).Value & "/" & _
Range("C" & k).Value & "/" & _
Range("D" & l).Value
lastrow = lastrow + 1
CountComb = CountComb + 1
End If
Next: Next
Next: Next
Range("K1").Value = CountComb
Range("K3").Value = Now + 21
Application.ScreenUpdating = True
End Sub
Function TimeSum(Persons As String, Chr As String) As Double
Dim ArrayPersons() As String: ArrayPersons = Split(Persons, Chr)
Dim SumOfTime As Double
Dim ItemPerson As Variant
Dim NumberRoutines As Long: NumberRoutines = 2
Const SheetData = "Sheet1"
For Each ItemPerson In ArrayPersons
SumOfTime = Sheets(SheetData).Columns(NumberRoutines).Find(ItemPerson).Offset(0, -1).Value + SumOfTime
NumberRoutines = NumberRoutines + 2
Next ItemPerson
TimeSum = SumOfTime
End Function
Maybe you could define better the sub to do what you desire for, but, the last coding could guide you in the right path. In a second thought, you could get combinations in a dictionary instead.
[
[
I use this function to decode UTF-8:
function DecodeUTF8(s)
dim i
dim c
dim n
i = 1
do while i <= len(s)
c = asc(mid(s,i,1))
if c and &H80 then
n = 1
do while i + n < len(s)
if (asc(mid(s,i+n,1)) and &HC0) <> &H80 then
exit do
end if
n = n + 1
loop
if n = 2 and ((c and &HE0) = &HC0) then
c = asc(mid(s,i+1,1)) + &H40 * (c and &H01)
else
c = 191
end if
s = left(s,i-1) + chr(c) + mid(s,i+n)
end if
i = i + 1
loop
DecodeUTF8 = s
end function
But there are some probles to decode that characters:
€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ
In that case
c=191-->c='¿'
I found some info related with this problem:
http://www.i18nqa.com/debug/utf8-debug.html
Do you know any function to decode correctly?
Public Function DecodeUTF8(s)
Set stmANSI = Server.CreateObject("ADODB.Stream")
s = s & ""
On Error Resume Next
With stmANSI
.Open
.Position = 0
.CharSet = "Windows-1252"
.WriteText s
.Position = 0
.CharSet = "UTF-8"
End With
DecodeUTF8 = stmANSI.ReadText
stmANSI.Close
If Err.number <> 0 Then
lib.logger.error "str.DecodeUTF8( " & s & " ): " & Err.Description
DecodeUTF8 = s
End If
On error Goto 0
End Function
I'm developing a program in visual basic 6.0 to display magic square. I've developed the logic, but the values are not getting displayed in the magic square. Here's the code :
Private Sub Command1_Click()
Dim limit As Integer
Dim a(100, 100) As Integer
limit = InputBox("Enter the limit")
If limit Mod 2 = 0 Then ' Rows and columns must be
MsgBox "Can't be done", vbOKCancel, "Error"
Else ' set number of rows and columns to limit
mfgsquare.Rows = limit
mfgsquare.Cols = limit
j = (n + 1) / 2
i = 1
For c = 1 To n * n
mfgsquare.TextMatrix(i, j) = c
If c Mod n = 0 Then
i = i + 1
GoTo label
End If
If i = 1 Then
i = n
Else
i = i - 1
End If
If j = n Then
j = 1
Else
j = j + 1
End If
label:
Next c
End If
End Sub
Try this:
n = InputBox("Enter the limit")
If n Mod 2 = 0 Then ' Rows and columns must be
MsgBox "Can't be done"
Else ' set number of rows and columns to limit
mfgsquare.Rows = n + 1
mfgsquare.Cols = n + 1
For i = 1 To n
For j = 1 To n
mfgsquare.TextMatrix(i, j) = n * ((i + j - 1 + Int(n / 2)) Mod n) + ((i + 2 * j - 2) Mod n) + 1
Next j
Next i
End If
Quick question that I've been struggling with. I have 2 arrays of different lengths that contain strings.
I want to output a new array which removes BOTH the elements if a duplicate is detected. At the moment it only removes duplicates but leaves the original which is incorrect for what I am trying to accomplish.
E.g.
input = array ("cat","dog","mouse","cat")
expected output = array ("dog","mouse")
actual output = array ("cat","dog","mouse")
Code is below:
Sub removeDuplicates(CombinedArray)
Dim myCol As Collection
Dim idx As Long
Set myCol = New Collection
On Error Resume Next
For idx = LBound(CombinedArray) To UBound(CombinedArray)
myCol.Add 0, CStr(CombinedArray(idx))
If Err Then
CombinedArray(idx) = Empty
dups = dups + 1
Err.Clear
ElseIf dups Then
CombinedArray(idx - dups) = CombinedArray(idx)
CombinedArray(idx) = Empty
End If
Next
For idx = LBound(CombinedArray) To UBound(CombinedArray)
Debug.Print CombinedArray(idx)
Next
removeBlanks (CombinedArray)
End Sub
Thanks for all help and support in advance.
What about using Scripting.Dictionary? Like this:
Function RemoveDuplicates(ia() As Variant)
Dim c As Object
Set c = CreateObject("Scripting.Dictionary")
Dim v As Variant
For Each v In ia
If c.Exists(v) Then
c(v) = c(v) + 1
Else
c.Add v, 1
End If
Next
Dim out() As Variant
Dim nOut As Integer
nOut = 0
For Each v In ia
If c(v) = 1 Then
ReDim Preserve out(nOut) 'you will have to increment nOut first, if you have 1-based arrays
out(nOut) = v
nOut = nOut + 1
End If
Next
RemoveDuplicates = out
End Function
Here is a quick example. Let me know if you get any errors.
Sub Sample()
Dim inputAr(5) As String, outputAr() As String, temp As String
Dim n As Long, i As Long
inputAr(0) = "cat": inputAr(1) = "Hen": inputAr(2) = "mouse"
inputAr(3) = "cat": inputAr(4) = "dog": inputAr(5) = "Hen"
BubbleSort inputAr
For i = 1 To UBound(inputAr)
If inputAr(i) = inputAr(i - 1) Or inputAr(i) = temp Then
inputAr(i - 1) = "": temp = inputAr(i): inputAr(i) = ""
End If
Next i
n = 0
For i = 1 To UBound(inputAr)
If inputAr(i) <> "" Then
n = n + 1
ReDim Preserve outputAr(n)
outputAr(n) = inputAr(i)
End If
Next i
For i = 1 To UBound(outputAr)
Debug.Print outputAr(i)
Next i
End Sub
Sub BubbleSort(arr)
Dim value As Variant
Dim i As Long, a As Long, b As Long, c As Long
a = LBound(arr): b = UBound(arr)
Do
c = b - 1
b = 0
For i = a To c
value = arr(i)
If (value > arr(i + 1)) Xor False Then
arr(i) = arr(i + 1)
arr(i + 1) = value
b = i
End If
Next
Loop While b
End Sub
EDIT
Another way without sorting
Sub Sample()
Dim inputAr(5) As String, outputAr() As String
Dim n As Long, i As Long, j As Long
Dim RemOrg As Boolean
inputAr(0) = "cat": inputAr(1) = "Hen": inputAr(2) = "mouse"
inputAr(3) = "cat": inputAr(4) = "dog": inputAr(5) = "Hen"
For i = 0 To UBound(inputAr)
For j = 1 To UBound(inputAr)
If inputAr(i) = inputAr(j) Then
If i <> j Then
inputAr(j) = "": RemOrg = True
End If
End If
Next
If RemOrg = True Then
inputAr(i) = ""
RemOrg = False
End If
Next i
n = 0
For i = 0 To UBound(inputAr)
If inputAr(i) <> "" Then
n = n + 1
ReDim Preserve outputAr(n)
outputAr(n) = inputAr(i)
End If
Next i
For i = 1 To UBound(outputAr)
Debug.Print outputAr(i)
Next i
End Sub