Simple fault probably but I can´t find the error. The code belows says one of my "else" has no "if". But I cant find out why...
Help please :)
whether i missed to add end if or some other problem?
Sub In_knapp_Click()
Dim i As Long
Dim g As Long
Dim a As Long
Dim b As Long
b = 3
For a = 1 To 7 Step 1
If Weekday(Now(), vbMonday) = a Then
For g = 3 To 12 Step 2
If g = 11 Then
MsgBox "Ingen Ut tid hittades"
Exit For
Else
If IsEmpty(Worksheets("Pontevedra").Cells(b, g).Value) Then
For i = 2 To 10 Step 2
If IsEmpty(Worksheets("Pontevedra").Cells(b, i).Value) Then
Worksheets("Pontevedra").Cells(b, i).Value = Now
ButtonOneClick = True
Exit For
Else
MsgBox "Fel"
End If
Else
Next g
End If
Else
b = b + 1
End If
Next a
End Sub
i cant find any help
You are missing a Next I and a few End Ifs - this compiles but may not be what you are trying to do :
Sub In_knapp_Click()
Dim i As Long
Dim g As Long
Dim a As Long
Dim b As Long
b = 3
For a = 1 To 7 Step 1
If Weekday(Now(), vbMonday) = a Then
For g = 3 To 12 Step 2
If g = 11 Then
MsgBox "Ingen Ut tid hittades"
Exit For
Else
If IsEmpty(Worksheets("Pontevedra").Cells(b, g).Value) Then
For i = 2 To 10 Step 2
If IsEmpty(Worksheets("Pontevedra").Cells(b, i).Value) Then
Worksheets("Pontevedra").Cells(b, i).Value = Now
ButtonOneClick = True
Exit For
Else
MsgBox "Fel"
End If
Next i
Else
' ?
End If
'?
End If
Next g
Else
b = b + 1
End If
Next a
End Sub
Related
I am trying to write a function that loops through column values and applies numbers 1,2,3...n in between cells with strings. for example:
data:
hefew
1
3
2
6
bkifew
3
4
2
1
3
I want the function to change the values to:
hefew
1
1
1
1
bkifew
2
2
2
2
2
There could be multiple strings, so the end value could end up being 15 or so.
I have started a basic function but I am not familiar enough with VBA to work the logic. I program in Python and would normally do stuff like this in that language. However, I'm forced to keep this within excel.
current working:
Sub Button2_Click()
Dim rng As Range, cell As Range
cellcount = CountA("A1:A1000")
Set rng = Range("A1:A10")
For Each cell In rng
a = cell.Value
If IsNumeric(a) = True Then
cell.Value = 1
Else
cell.Value = 0
End If
Next cell
End Sub
I don't think this is possible with a for loop. Is there some sort of search and replace function that I could use?
Try this, assuming the numbers are not the result of formulae.
Sub x()
Dim r As Range, n As Long
For Each r In Columns(1).SpecialCells(xlCellTypeConstants, xlNumbers).Areas
n = n + 1
r.Value = n
Next r
End Sub
I created a function instead of sub which is little bit messy but it works. Tested at my pc
Public Function Test(checkrange As Range, checkcell As Range)
Dim cll As Range
Dim arr() As Variant
ReDim Preserve arr(1 To checkrange.Cells.Count)
If IsNumeric(checkcell.Value) = False Then
Test = checkcell.Value
Exit Function
End If
y = 1
For Each cll In checkrange
If IsNumeric(cll.Value) Then
arr(y) = 1
Else
arr(y) = 0
End If
y = y + 1
Next cll
m = 1
For Each cll In checkrange
If cll.Address = checkcell.Address Then
rownumber = m
Exit For
End If
m = m + 1
Next cll
m = 0
For i = LBound(arr) To UBound(arr)
If arr(i) = 0 Then
m = m + 1
End If
If i = rownumber Then Exit For
Next i
Test = m
End Function
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 was wondering why the following syntax does not work the way I thought it would in VBA, and what I should do to ensure it does;
For a = 1 To 10
For b = 1 To 10
For c = 1 To 10
If a <> b <> c Then
MsgBox (a & " " & b & " " & c)
End If
Next c
Next b
Next a
This is a simplified example, which can still be manually obtained with:
if a<>b and b<>c and c<>a then
But my actual intended code has 10 such variables multiple times, which makes it unfeasible with 55 unequal conditions, or likely for me to make a typo. I think there is a more efficient way but I have not found it.
Ps. My goal is to only have a message box pop up if all the variables are unique.
I have obtained my goal, though it can probably be done much more efficient than:
For a = 1 To 10
check(a) = True
For b = 1 To 10
If check(b) = False Then
check(b) = True
For c = 1 To 10
If check(c) = False Then
check(c) = True
For d = 1 To 10
If check(d) = False Then
check(d) = True
For e = 1 To 10
If check(e) = False Then
check(e) = True
MsgBox (a & " " & b & " " & c & " " & d & " " & e)
End If
check(e) = False
check(a) = True
check(b) = True
check(c) = True
check(d) = True
Next e
End If
check(d) = False
check(a) = True
check(b) = True
check(c) = True
Next d
End If
check(c) = False
check(a) = True
check(b) = True
Next c
End If
check(b) = False
check(a) = True
Next b
Next a
Here is an implementation of the Johnson-Trotter algorithm for enumerating permutations. It is a small modification of one that I wrote once when playing around with brute-force solutions to the Traveling Salesman Problem. Note that it returns a 2-dimensional array, which might consume a lot of memory. It is possible to refactor it so that it is a sub where the permutations are consumed rather than stored. Just replace the part of the code near the bottom (where the current permutation, perm, is stored in the array perms) by the code that uses the permutation.
Function Permutations(n As Long) As Variant
'implements Johnson-Trotter algorithm for
'listing permutations. Returns results as a variant array
'Thus not feasible for n > 10 or so
Dim perm As Variant, perms As Variant
Dim i As Long, j As Long, k As Long, r As Long, D As Long, m As Long
Dim p_i As Long, p_j As Long
Dim state As Variant
m = Application.WorksheetFunction.Fact(n)
ReDim perm(1 To n)
ReDim perms(1 To m, 1 To n) As Integer
ReDim state(1 To n, 1 To 2) 'state(i,1) = where item i is currently in perm
'state(i,2) = direction of i
k = 1 'will point to current permutation
For i = 1 To n
perm(i) = i
perms(k, i) = i
state(i, 1) = i
state(i, 2) = -1
Next i
state(1, 2) = 0
i = n 'from here on out, i will denote the largest moving
'will be 0 at the end
Do While i > 0
D = state(i, 2)
'swap
p_i = state(i, 1)
p_j = p_i + D
j = perm(p_j)
perm(p_i) = j
state(i, 1) = p_j
perm(p_j) = i
state(j, 1) = p_i
p_i = p_j
If p_i = 1 Or p_i = n Then
state(i, 2) = 0
Else
p_j = p_i + D
If perm(p_j) > i Then state(i, 2) = 0
End If
For j = i + 1 To n
If state(j, 1) < p_i Then
state(j, 2) = 1
Else
state(j, 2) = -1
End If
Next j
'now find i for next pass through loop
If i < n Then
i = n
Else
i = 0
For j = 1 To n
If state(j, 2) <> 0 And j > i Then i = j
Next j
End If
'record perm in perms:
k = k + 1
For r = 1 To n
perms(k, r) = perm(r)
Next r
Loop
Permutations = perms
End Function
Tested like:
Sub test()
Range("A1:G5040").Value = Permutations(7)
Dim A As Variant, i As Long, s As String
A = Permutations(10)
For i = 1 To 10
s = s & " " & A(3628800, i)
Next i
Debug.Print s
End Sub
The first 20 rows of output look like:
Also, 2 1 3 4 5 6 7 8 9 10 is printed in the immediate window. My first version used a vanilla variant away and caused an out-of-memory error with n = 10. I tweaked it so that perms is redimensioned to contain integers (which consume less memory than variants) and is now able to handle 10. It takes about 10 seconds on my machine to run the test code.
You could simply add a check right after the beginning of each inner loop, like follows
For a = 1 To 10
For b = 1 To 10
If b <> a Then '<-- this check will make sure subsequent inner loops shouldn't bother but for their loops variables
For c = 1 To 10
If c <> b Then '<-- same comment as preceeding one
For d = 1 to 10
If d <> c then MsgBox (a & " " & b & " " & c & " " & d) '<-- last check for last two variables
Next d
End If
Next c
End If
Next b
Next a
Try putting all those variables into the array and checking the array for duplicates, if none found, display the message box. Something like this:
Sub dupfind()
Dim ArrHelper(2) As Long
Dim k As Long
Dim j As Long
Dim ans As Long
Dim dupl As Boolean
Dim ArrAnswers() As Long
ans = 0
For a = 1 To 10
ArrHelper(0) = a
For b = 2 To 10
ArrHelper(1) = b
For c = 1 To 10
ArrHelper(2) = c
dupl = False
For k = 0 To UBound(ArrHelper) - 1
For j = k + 1 To UBound(ArrHelper)
If ArrHelper(k) = ArrHelper(j) Then
dupl = True
End If
Next j
Next k
If dupl = False Then
ReDim Preserve ArrAnswers(3, ans)
ArrAnswers(0, ans) = a
ArrAnswers(1, ans) = b
ArrAnswers(2, ans) = c
ans = ans + 1
End If
Next c
Next b
Next a
End Sub
Read your edit regarding storing permutations and changed the code a bit
I have following code:
Sub nummm()
Dim num() As String
For x = 2 To 1000
c = 0
ReDim Preserve num(UBound(Split(Cells(x, 7).Value, " ")) + 1)
num = Split(Cells(x, 7).Value, " ")
For Each b In num
c = c + 1
If c = UBound(num) + 1 Then GoTo vv:
Next
vv:
Next
End Sub
It's running fine if I remove line
If c = UBound(num) + 1 Then GoTo vv:
but if it's not removed, I get run-time error: "This array is fixed or temporarily locked"
How can I make variable num dynamic?
thx for help
I don't know how your b and other variables (except num) are declared but maybe this could help you:
Sub nummm()
Dim num As Variant 'So you can directly assign the array from Split
For x = 2 To 1000
c = 0
num = Split(Cells(x, 7).Value, " ")
For Each b In num
c = c + 1
'Rather than "GoTo somewhere", "Exit For" will exit the current For loop
If c = UBound(num) + 1 Then Exit For
Next b
Next x
End Sub
Problem description:
Take a stack of coins all heads up. Upturn the topmost coin and then proceed: take the top 2 coins and upturn as a single stack (tail, head becomes when upturned and placed back on the stack tail, head (the two coins are flipped as if glued together)). Now in the same way flip the top 3 coins and place back on the stack (you get: tail, tail, head (and if there were 4 coins that would be tail, tail, tail, head). When you upturn the whole stack begin again with the first coin. Continue until you return to a stack with all heads up.
(Hope that's clear)
Can anybody see why this small program should fail? The example for me where I first notice an error is when count reaches 18 with a stack of 6 coins.
I placed a button on a spreadsheet and call FlippingCoins...
Sub FlippingCoins()
Call theStackOfCoins
Call theFlipping
End Sub
Sub theStackOfCoins()
Worksheets("Sheet3").Cells(1, 3).Select
Columns("A:b").Select
Selection.ClearContents
Range("a3").Select
Dim StackOfCoins As Integer
StackOfCoins = Worksheets("Sheet3").Cells(1, 3).Value
Dim row As Integer
row = 0
For theStack = 1 To StackOfCoins
Worksheets("Sheet3").Cells(row + theStack, 1).Value = True
Next theStack
End Sub
Sub theFlipping()
Dim middleCoin As Integer
middleCoin = 0
Dim passes As Integer
passes = 0
Dim Fst As Integer
Fst = 0
Dim Lst As Integer
Lst = 0
Dim stack As Integer
stack = Worksheets("Sheet3").Cells(1, 3).Value
Dim Flip_x_coins As Integer
Flip_x_coins = 0
Dim count As Integer
count = 0
Dim Finished As Boolean
Finished = False
Reset:
Flip_x_coins = 1
For Flip_x_coins = 1 To stack
Worksheets("Sheet3").Cells(1, 4).Value = Flip_x_coins
count = count + 1
If Flip_x_coins = 1 Then
Worksheets("Sheet3").Cells(1, 1).Value = Not (Worksheets("Sheet3").Cells(1, 1).Value)
Else
passes = Int(Flip_x_coins) / 2
Fst = 1
Lst = Flip_x_coins
For pass = 1 To passes
If Worksheets("Sheet3").Cells(Fst, 1).Value = Worksheets("Sheet3").Cells(Lst, 1).Value Then
Worksheets("Sheet3").Cells(Fst, 1).Value = Not (Worksheets("Sheet3").Cells(Fst, 1).Value)
Worksheets("Sheet3").Cells(Lst, 1).Value = Not (Worksheets("Sheet3").Cells(Lst, 1).Value)
End If
Fst = Fst + 1
Lst = Flip_x_coins - 1
Next pass
If Flip_x_coins Mod 2 > 0 Then
middleCoin = (Flip_x_coins + 1) / 2
Worksheets("Sheet3").Cells(middleCoin, 1).Value = Not (Worksheets("Sheet3").Cells(middleCoin, 1).Value)
End If
End If
For testComplete = 1 To stack
If Worksheets("Sheet3").Cells(testComplete, 1).Value = False Then
Finished = False
Exit For
Else
Finished = True
End If
Next testComplete
Worksheets("Sheet3").Cells(1, 2).Value = count
If Finished = True Then
Exit For
End If
MsgBox "Next."
If Flip_x_coins = stack Then
GoTo Reset
End If
Next Flip_x_coins
End Sub
Thanks in advance
Regards
In the For pass = 1 To passes loop, Lst = Flip_x_coins - 1 is wrong.
It should be: Lst = Lst - 1
On pass 18 with 6 coins, the macro compares rows 1 and 6 followed by rows 2 and 5 followed by rows 3 and 5. Obviously the last comparison should be between rows 3 and 4 instead.
I hope this isn't homework because there are lots of other problems with the macro. For example:
no Option Explicit at the start of the macro. This has allowed you to use three variables which you haven't declared - theStack, pass, testComplete
incorrect rounding. Given that Flip_x_coins is of Integer type, passes = Int(Flip_x_coins) / 2 is nonsense. Try passes = Int(Flip_x_coins / 2) instead
using Goto is generally a bad idea. It has some use in VBA for error handling but, in this case, you could easily use a Do Until finished ... Loop construct instead
I suspect this
Fst = Fst + 1
Lst = Flip_x_coins - 1
Next pass
should be
Fst = Fst + 1
Lst = Lst - 1
Next pass
Sub Flip()
Dim rw As Range
Dim numCoins As Integer
Dim iCoins As Integer, iCoin As Integer, flipCoins As Integer
Dim v
numCoins = 6
Set rw = Sheet1.Range("B2").Resize(1, numCoins) 'all start as "TRUE"
rw.Value = True
Do
For flipCoins = 1 To numCoins
For iCoin = 1 To numCoins
If iCoin <= flipCoins Then
v = Not rw.Cells(flipCoins - (iCoin - 1)).Value
Else
v = rw.Cells(iCoin).Value
End If
rw.Offset(1, 0).Cells(iCoin).Value = v
Next iCoin
Set rw = rw.Offset(1, 0)
rw.EntireRow.Cells(1).Value = "Flipped " & flipCoins
If Application.CountIf(rw, "FALSE") = 0 Then
Debug.Print "All Heads at row " & rw.Row
Exit Do
End If
Next flipCoins
Loop While rw.Row < 1000 'don't go on for ever...
End Sub