I'm having trouble with the if statement inside a loop. Every time I try and run it, it gives me an error of:
next without for
Sub CheckDates4()
Dim count As Integer
Dim i As Integer
Dim j As Integer
count = 0
i = 2
j = 24
For i = 2 To 318
For j = 46 To 1 Step (-2)
If Sheet1.Cells(i, j) >= Sheet2.Cells(1, 1) And Sheet1.Cells(i, j - 1) = "Reçu" Then
count = count + 1
Next i
Next j
End If
Sheet2.Cells(1, 7) = count
End Sub
Any ideas how to fix this?
You should first close the If condition with End If. Then, close the inner For loop with Next j. Finally, close the outer For loop with Next i. So, your code should look like this:
Sub CheckDates4()
Dim count As Integer
Dim i As Integer
Dim j As Integer
count = 0
i = 2
j = 24
For i = 2 To 318
For j = 46 To 1 Step (-2)
If Sheet1.Cells(i, j) >= Sheet2.Cells(1, 1) And Sheet1.Cells(i, j - 1) = "Reçu" Then
count = count + 1
End If
Next j
Next i
Sheet2.Cells(1, 7) = count
End Sub
Your END IF was in the wrong place and you've swapped your NEXTs as well:
For i = 2 To 318
For j = 46 To 1 Step (-2)
If Sheet1.Cells(i, j) >= Sheet2.Cells(1, 1) And Sheet1.Cells(i, j - 1) = "Reçu" Then
count = count + 1
End If
Next
Next
Related
Ok, I have the code below, which takes 18 different words, all in Column A rows 1 to 18, and tries them in all different combos to find a seven word palindrome. I am pretty sure the code will get it done, but it just searches for a LONG time. I know there's a way to check the first and last letters of the combos, to make sure they're the same, before the code runs them through the REVERSE function, I just can't figure out how to do it. I am very new to this.In other words, each time it puts together 7 of the words, if it didn't have to go through the REVERSE function, a ton of time would be saved, and verification that the first and last letters match would do that. Thanks in advance for any help
Sub SevenDrome()
Dim count As Integer
count = 0
Dim wordtest As String
Dim wordpal As String
For j = 1 To 18
For k = 1 To 18
For l = 1 To 18
For m = 1 To 18
For n = 1 To 18
For o = 1 To 18
For p = 1 To 18
wordtest = Cells(j, 1) & Cells(k, 1) & Cells(l, 1) & Cells(m, 1) & Cells(n, 1) & Cells(o, 1) & Cells(p, 1)
wordpal = REVERSE(wordtest)
If wordtest = wordpal Then
count = count + 1
Cells(count, 7) = wordtest
End If
Next p
Next o
Next n
Next m
Next l
Next k
Next j
End Sub
Try, This results in 104,976 which takes less than 2 seconds.
Sub test()
Dim a(1 To 18)
Dim vR(1 To 1000000, 1 To 1)
Dim cnt As Long
Dim i As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, o As Integer
For i = 1 To 18
a(i) = Range("a" & i)
Next i
For j = 1 To 18
For k = 1 To 18
If a(j) = a(k) Then
For l = 1 To 18
For m = 1 To 18
If a(l) = a(m) Then
For n = 1 To 18
For o = 1 To 18
If a(n) = a(o) Then
For p = 1 To 18
cnt = cnt + 1
vR(cnt, 1) = a(j) & a(l) & a(n) & a(p) & a(o) & a(m) & a(k)
DoEvents
Next p
End If
Next o
Next n
End If
Next m
Next l
End If
Next k
Next j
Range("g1").Resize(cnt) = vR
End Sub
Data image
Result Image
If each cell has more than 2 characters, you can do as follows.
Sub test2()
Dim a(1 To 18)
Dim vR(1 To 1000000, 1 To 1)
Dim cnt As Long
Dim i As Integer, k As Integer, l As Integer
Dim m As Integer, n As Integer, o As Integer
For i = 1 To 18
a(i) = Range("a" & i)
Next i
For j = 1 To 18
For k = 1 To 18
If a(j) = Reverse(a(k)) Then
For l = 1 To 18
For m = 1 To 18
If a(l) = Reverse(a(m)) Then
For n = 1 To 18
For o = 1 To 18
If a(n) = Reverse(a(o)) Then
For p = 1 To 18
If a(p) = Reverse(a(p)) Then
cnt = cnt + 1
vR(cnt, 1) = a(j) & a(l) & a(n) & a(p) & a(o) & a(m) & a(k)
DoEvents
End If
Next p
End If
Next o
Next n
End If
Next m
Next l
End If
Next k
Next j
Range("g1").CurrentRegion.Clear
If cnt Then
Range("g1").Resize(cnt) = vR
End If
End Sub
Function Reverse(s)
Dim i As Integer
Dim myS As String
For i = Len(s) To 1 Step -1
myS = myS & Mid(s, i, 1)
Next i
Reverse = myS
End Function
Case 2 Data
Case 2 Result
I have challenges in highlighting/copying alternate rows in one column and pasting it to the next column and aligned.
Here's a screenshot:
Following code assumes you have two separate tabs, SRC and DST and the range of data starts in the first cell. Will do all in a single step:
Public Sub CopyAlternate()
Dim i As Long
i = 2
While Len(Sheets("SRC").Cells(i, 1).Value) > 0
Sheets("DST").Cells(i / 2 + 1, 1).Value = Sheets("SRC").Cells(i, 1).Value
Sheets("DST").Cells(i / 2 + 1, 2).Value = Sheets("SRC").Cells(i + 1, 1).Value
i = i + 2
Wend
End Sub
You can take this code and adjust it to taste:
Sub alternate()
Dim i As Integer
Dim j As Integer
Dim n As Integer
i = 0
j = 0
n = 0
With ActiveSheet
For Each c In .Range("A4:A16")
.Cells(20 + j, 1 + i).Value = c.Value
If n = 0 Or n Mod 2 = 0 Then
i = 1
j = j
Else
i = 0
j = j + 1
End If
n = n + 1
Next c
End With
End Sub
This worked for me when rebuilding your example with letters (for faster checking).
I'd like to use Excel as my poker dealer. Here is the code that will generate 20 random numbers (cards) between 1 and 52. Output of first 20 numbers/cards is in column A1:A20. I'd like to have the next set of 20 numbers/cards generated in A22:A41, 3rd A43:A62, and so on. How can the code be fixed so that it displays 1000 hands in column A with one row separating each set? Thank you.
Sub cards()
Range("A:A").Clear
cardstodraw = 20
For x = 1 To cardstodraw
begL:
ActiveSheet.Cells(1, 2) = "=Randbetween(1,52)"
ActiveSheet.Cells(x, 1) = ActiveSheet.Cells(1, 2).Text
cardvalue = ActiveSheet.Cells(x, 1)
y = 1
Count = 0
Do Until ActiveSheet.Cells(y, 1) = ""
If ActiveSheet.Cells(y, 1) = cardvalue Then
Count = Count + 1
End If: y = y + 1: Loop
If Count > 1 Then GoTo begL
Next
Range("B1").Clear
End Sub
Your code is somewhat convoluted (using GoTo is usually an indication that something can be improved). For getting a sample of size 20 from 1-52, use a modified Fisher-Yates shuffle:
Option Explicit 'you really should be using this
Function deal(n As Long, k As Long) As Variant
'returns an array of length k
'consisting of k numbers in the range 1 to n
Dim deck As Variant
Dim i As Long, j As Long, temp As Long
ReDim deck(1 To n)
For i = 1 To n
deck(i) = i
Next i
With Application.WorksheetFunction
'do k steps of a Fisher-Yates shuffle on deck
For i = 1 To .Min(k, n - 1)
j = .RandBetween(i, n)
If i < j Then 'swap
temp = deck(i)
deck(i) = deck(j)
deck(j) = temp
End If
Next i
End With
ReDim Preserve deck(1 To k)
deal = deck
End Function
If you want to have 1000 hands in Column A:
Sub ManyHands()
Dim i As Long
With Application.WorksheetFunction
For i = 1 To 1000
Range(Cells(1 + 21 * (i - 1), 1), Cells(21 * i - 1, 1)).Value = .Transpose(deal(52, 20))
Next i
End With
End Sub
On Edit Here is a modified version of the code, one which deals cards to multiple players:
Function deal(n As Long, k As Long, players As Long) As Variant
'returns an array with k rows and players columns
'consisting of k*players numbers in range 1 to n
'if players = 1, then the array is 1-dimensional
'otherwise it is 2-dimensional
Dim deck As Variant
Dim i As Long, j As Long, temp As Long
Dim hands As Variant
ReDim deck(1 To n)
For i = 1 To n
deck(i) = i
Next i
With Application.WorksheetFunction
'do k*players steps of a Fisher-Yates shuffle on deck
For i = 1 To .Min(k * players, n - 1)
j = .RandBetween(i, n)
If i < j Then 'swap
temp = deck(i)
deck(i) = deck(j)
deck(j) = temp
End If
Next i
End With
ReDim Preserve deck(1 To k * players)
If players = 1 Then
deal = deck
Exit Function
Else
ReDim hands(1 To k, 1 To players)
For i = 1 To k
For j = 1 To players
hands(i, j) = deck(players * (i - 1) + j)
Next j
Next i
deal = hands
End If
End Function
It could be used like:
Sub ManyHands()
Dim i As Long
For i = 1 To 1000
Range(Cells(1 + 11 * (i - 1), 1), Cells(11 * i - 1, 2)).Value = deal(52, 10, 2)
Next i
End Sub
Try:
Sub cards()
Dim cardstodraw As Long, numberofhands As Long, i As Long, j As Long, k As Long
cardstodraw = 20
numberofhands = 50
Range("A:A").Clear
With Application.WorksheetFunction
For j = 0 To numberofhands - 1
For i = 1 To cardstodraw
begL:
Cells(i + k + (j * cardstodraw), 1) = .RandBetween(1, 52)
If .CountIf(Range(Cells(1 + k + (j * cardstodraw), 1), Cells(20 + k + (j * cardstodraw), 1)), Cells(i + k + (j * cardstodraw), 1)) > 1 Then GoTo begL
Next i
k = k + 1
Next j
End With
End Sub
thanks in advance for taking the time to help. I have built a Do While loop in VBA that for some reason breaks when j = 1. I have in cells C3:C7 these values: 13,14,14,13,14.
Here's the short script:
Dim i, j, n As Integer
Dim List(0) As Integer
i = o
j = 0
n = 0
Do While Cells(i + 3, 3) <> ""
If Cells(i + 3, 3) > 13 Then
List(j) = i + 3
j = j + 1
Cells(i + 3, 4) = "Noted"
i = i + 1
ElseIf Cells(i + 3, 3) = 13 Then
Cells(i + 3, 4) = "Skipped"
i = i + 1
Else
i = i + 1
End If
Loop
For n = j To n = 0
Rows(List(n)).Delete
Next
Thanks again!
Your intent is sound, but there are quite a few errors. See commented code below for details
Sub Demo()
' ~~ must explicitly type each variable. Use Long
Dim i As Long, j As Long, n As Long
Dim List() As Long '<~~ dynamic array
i = 3 '<~~ eliminate the klunky +3
j = 0
n = 0
ReDim List(0 To 0) '<~~ initialise dynamic array
Do While Cells(i, 3) <> vbNullString
If Cells(i, 3) > 13 Then
ReDim Preserve List(0 To j) '<~~ resize array
List(j) = i
j = j + 1
Cells(i, 4) = "Noted"
ElseIf Cells(i, 3) = 13 Then
Cells(i, 4) = "Skipped"
End If
i = i + 1 '<~~ simplify, its called in each if case anyway
Loop
' j will end up 1 greater than size of array
If j > 0 Then '<~~ only execute if we found some rows to delete
For n = j - 1 To 0 Step -1 '<~~ For loop syntax
Rows(List(n)).Delete
Next
End If
End Sub
How can it be difficult to add buttons showing previous and next entries on the userform? There is a bunch of source on the net. I've tried many of them but no go. I have tried to adapt one of the solutions mentioned in this very site, I failed. :(
In the column A there are item numbers (say 180) It may be according to 180 or to as long as it gets. I want to add the previous and next buttons. Then buttons to show the first and last entry.
My code is:
Private Sub UserForm_Initialize()
Dim k As Long, j As Long
Dim rng As Range
Set rng = Worksheets("BİLGİLER").Range("A180")
k = 0: j = 1
vyakinligi.Value = rng.Offset(k).Value
vadsoyad.Value = rng.Offset(k, j).Value: j = j + 1
vmeslegi.Value = rng.Offset(k, j).Value: j = j + 1
visadresi.Value = rng.Offset(k, j).Value: j = j + 1
vceptel.Value = rng.Offset(k, j).Value: j = j + 1
End Sub
'~~> Next Button
Private Sub CommandButton7_Click()
k = k + 1: j = 1
If k > (Sheets("BİLGİLER").Rows.Count - 4) Then
MsgBox "Max rows Reached"
Exit Sub
End If
vyakinligi.Value = rng.Offset(k).Value
vadsoyad.Value = rng.Offset(k, j).Value: j = j + 1
vmeslegi.Value = rng.Offset(k, j).Value: j = j + 1
visadresi.Value = rng.Offset(k, j).Value: j = j + 1
vceptel.Value = rng.Offset(k, j).Value: j = j + 1
End Sub
'~~> Previous Button
Private Sub CommandButton8_Click()
k = k - 1: j = 1
If k < 0 Then
MsgBox "1st Row Reached"
Exit Sub
End If
vyakinligi.Value = rng.Offset(k).Value
vadsoyad.Value = rng.Offset(k, j).Value: j = j + 1
vmeslegi.Value = rng.Offset(k, j).Value: j = j + 1
visadresi.Value = rng.Offset(k, j).Value: j = j + 1
vceptel.Value = rng.Offset(k, j).Value: j = j + 1
End Sub
Where did I go wrong? What should I do to add the buttons and show previous, next, first and the last entry on the userform?
I managed to run (to adapt) the code finally. I will put it here in case someone makes use of it.
In general tab:
Dim Data As Variant
Dim LastRow As Long
Dim r As Long
The previous and next buttons:
Private Sub CommandButton7_Click()
RangeRow xlNext
End Sub
Private Sub CommandButton8_Click()
RangeRow xlPrevious
End Sub
To userform's initialize section:
With Sheets("BİLGİLER") 'change the name as you wish
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Data = .Range("A1:AZ" & LastRow).Value 'data range
End With
r = ActiveCell.Row - 1
RangeRow r
And this Subroutine code:
Sub RangeRow(ByVal Direction As Long)
r = IIf(Direction = xlPrevious, r - 1, r + 1)
If r < 2 Then r = 2
If r > LastRow Then r = LastRow
With Me
.sira.Text = Data(r, 1)
.tckn.Text = Data(r, 2)
.oadsoyad.Text = Data(r, 3)
.cinsiyet.Text = Data(r, 4)
.dyeri.Text = Data(r, 5)
.dyili.Text = Data(r, 6)
.ncsn.Text = Data(r, 7)
.babaadi.Text = Data(r, 8)
.anneadi.Text = Data(r, 9)
.kangrb.Text = Data(r, 10)
.oceptel.Text = Data(r, 11)
.oevadresi.Text = Data(r, 12)
End With
End Sub
This code takes the info from the related row on the table and fills the userform textboxes and comboboxes on the usefrorm.
Now it's time to put buttons for the first and the last entry. Any suggestions?