I have create this script in VBA
Sub code_piece_motoculture()
Randomize
caractere = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
lettre_nombre = ""
For i = 1 To 15
nombre_alea = Int(Len(caractere) * Rnd) + 1
lettre_nombre = lettre_nombre & Mid(caractere, nombre_alea, 1)
If i = 5 Then lettre_nombre = lettre_nombre & "-"
If i = 10 Then lettre_nombre = lettre_nombre & "-"
Next
Range("A1") = lettre_nombre
End Sub
And i have this result only in A1
ATBBM-YSHSS-G5ZVH
But i want different result on cells A2->A3->A4->A5 ect
Can you help me ?
Im sure there is cleaner, but this will achieve what you are looking for
Sub code_piece_motoculture()
Randomize
caractere = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
lettre_nombre = ""
For j = 1 To 10 'entrer le nombre de lignes desiree
For i = 1 To 15
nombre_alea = Int(Len(caractere) * Rnd) + 1
lettre_nombre = lettre_nombre & Mid(caractere, nombre_alea, 1)
If i = 5 Then lettre_nombre = lettre_nombre & "-"
If i = 10 Then lettre_nombre = lettre_nombre & "-"
Next
Range("A" & j) = lettre_nombre
lettre_nombre = ""
Next
End Sub
Try this function ...
Public Function GenerateRandomStuff() As String
Dim i As Long, lngNumber As Long, lngBetween As Long
For i = 1 To 15
lngBetween = WorksheetFunction.RandBetween(1, 2)
If lngBetween = 1 Then
lngNumber = WorksheetFunction.RandBetween(48, 57)
Else
lngNumber = WorksheetFunction.RandBetween(65, 90)
End If
GenerateRandomStuff = GenerateRandomStuff & Chr(lngNumber)
If i = 5 Then GenerateRandomStuff = GenerateRandomStuff & "-"
If i = 10 Then GenerateRandomStuff = GenerateRandomStuff & "-"
Next
End Function
... worked nicely for me.
You can add that to a cell and there's no need to extend your macro if you want to add it to more cells, you just copy and paste the formula ...
=GenerateRandomStuff()
... if you want to stop it from refreshing each time, copy and paste special values and you're done.
Related
i need a little bit help.
Is it possible to fill a list with random numbers and to check this list before each loop to see if the number already exists?
I think im on the wrong way with my VBA.
Sub Zufallszahlen()
Dim Rng As Range
Max = 6
Min = 1
Anzahl = 4
counter = 0
innercounter = 0
SZeile = 2
AWert = "X"
Range("C:C").Clear
Do
counter = counter + 1
ZZahl = Int((Max * Rnd) + Min)
innercounter = 0
Do
innercounter = innercounter + 1
If Cells(innercounter, 2) = ZZahl Then
ZZahl = Int((Max * Rnd) + Min)
Else
Loop Until innercounter = Anzahl
' Cells(counter, 1).Value = counter
Cells(counter, 2).Value = ZZahl
Cells(ZZahl, 3).Value = AWert
Loop Until counter = Anzahl
Range("B:B").Clear
End Sub
Use an array to check if random number has already been chosen. Repeat until a vacant array position is found.
Option Explicit
Sub Zufallszahlen()
Const MaxN = 6
Const MinN = 1
Const Anzahl = 4
Const Awert = "X"
Dim ar, n As Long, r As Long, i As Long
n = MaxN - MinN + 1
If n < Anzahl Then
MsgBox "Min to Max range must be >= " & Anzahl
Exit Sub
End If
' values in column B
Dim arB, total As Single, try As Long
arB = Range("B" & MinN).Resize(n).Value2
Do
' avoid endless loop
try = try + 1
If try > 100 Then
MsgBox "Could not solve in 100 tries", vbExclamation
Exit Sub
End If
' generate random selection
ReDim ar(1 To n, 1 To 1)
total = 0
For i = 1 To Anzahl
Do
r = 1 + Int(n * Rnd())
Loop Until ar(r, 1) = ""
ar(r, 1) = Awert
' sum col B
total = total + arB(r, 1)
Next
Range("C:C").Clear
Range("C" & MinN).Resize(n) = ar
Loop Until total >= 10 And total <= 20 ' check total in range
MsgBox "Total=" & Format(total, "0.00"), vbInformation, try & " tries"
End Sub
You can use the Scripting.Dictionary object to check.
Given it's a "Dictionary", it requires that all keys are unique.
This is a crude implementation demonstrating the random filling of that dictionary with all numbers between 50 and 100.
Public Sub DoRandomize()
Dim objUnique As Object, i As Long, lngRandom As Long
Dim lngMin As Long, lngMax As Long, dblRandom As Double
lngMin = 50: lngMax = 100
Set objUnique = CreateObject("Scripting.Dictionary")
Do While objUnique.Count <> (lngMax - lngMin) + 1
Randomize objUnique.Count
lngRandom = (Rnd(objUnique.Count) * (lngMax - lngMin)) + lngMin
If Not objUnique.exists(lngRandom) Then
Debug.Print "Adding ......... " & lngRandom
objUnique.Add lngRandom, vbNull
Else
Debug.Print "Already used ... " & lngRandom
End If
Loop
End Sub
... you'd just need to pull out the relevant parts for your implementation but you can paste that code into your project, run it and see it work for yourself.
Ty Guys thats perfect =) i use this now and it works very nice + i understand my
misconception
Sub Zufallszahlen()
Const MaxN = 29
Const MinN = 1
Const Anzahl = 4
Const Awert = "X"
Dim ar, n As Long, r As Long
n = MaxN - MinN + 1
If n < Anzahl Then
MsgBox "Min to Max range must be >= " & Anzahl
Exit Sub
End If
ReDim ar(1 To n, 1 To 1)
For i = 1 To Anzahl
Do
r = 1 + Int(n * Rnd())
Loop Until ar(r, 1) = ""
ar(r, 1) = Awert
Next
Range("C:C").Clear
Range("C" & MinN).Resize(n) = ar
End Sub
Buts not finally completed.
Can I include this part in another if?
This is intended to ensure that the values of the cells to the left of the cells randomly marked with an x add up to between 10 and 20, for example. Otherwise the random cells should be regenerated
I am slowly learning how to do some very basic routines in Excel VBA, but I dont know how to tackle this one.
How can I go from data in one row looking like this :
11-Jun,27.3,28.3,12-Jun,27.2,28.3,13-Jun,26.7,28.4,14-Jun,26.7,28.4
to 3 columns.
First column with date, 2nd with first value, 3rd with the second value ?
Thanks
Put your data in A1.
This will loop the data back to the desired column based on if there is a remainder left after dividing.
Option Explicit
Sub splitData()
Dim i, rownum, colnum As Integer
Dim str As Variant
colnum = 1
rownum = 2
str = Split(Cells(1, 1).Value, ",")
For i = 0 To UBound(str)
If i Mod 3 = 2 Then
Cells(rownum, 3).Value = "'" & str(i)
End If
If i Mod 3 = 1 Then
Cells(rownum, 2).Value = "'" & str(i)
End If
If i Mod 3 = 0 Then
rownum = rownum + 1
Cells(rownum, 1).Value = "'" & str(i)
End If
Next i
End Sub
Or maybe something like this :
Sub test()
x = Split(Range("A1"), ",")
y = (UBound(x) + 1) / 3
P = 1
For i = 1 To y
For Z = 1 To 3
Cells(i + 3, Z).Value = x(P - 1)
P = P + 1
Next
Next
End Sub
I'm trying to simplify my code to dynamically check some values and update a bunch of tickboxes.
The tickboxes are sort of a table, their name is "col" & number_of_column & type_of_data
ie:
Col1PAM Col2PAM Col3PAM
Col1RL Col2RL Col3RL
I tried a simple approach with for...next which works:`
For i = 1 To 16
If ThisWorkbook.Sheets("Setup").Cells(j + 2, i + 1) = 1 Then
Me.Controls("Col" & i & "PAM").Value = True
Else: Me.Controls("Col" & i & "PAM").Value = False
End If
If ThisWorkbook.Sheets("Setup").Cells(j + 3, i + 1) = 1 Then
Me.Controls("Col" & i & "RL").Value = True
Else: Me.Controls("Col" & i & "RL").Value = False
End If
Next i
But I have a lot of column types and I tried to make the column type dynamic:
Dim Coltype1 As String
Dim coltype2 As String
Coltype1 = "PAM"
coltype2 = "RL"
For j = 1 To 2
For i = 1 To 16
If ThisWorkbook.Sheets("Setup").Cells(j + 2, i + 1) = 1 Then
Me.Controls("Col" & i & ("Coltype" & j)).Value = True
Else: Me.Controls("Col" & i & ("Coltype" & j)).Value = False
End If
Next i
Next j
My syntax is incorrect and after many tries, I can't figure out what would be a proper one. Any advice ?
On a side note, I also tried the for...next approach to declare my coltype1, coltype2... variables but it looks like you can't do that?
Thanks for any tips!
Something like this:
Dim arr(1 To 2) As String, ws As WorkSheet, i As Long, j As Long
Set ws = ThisWorkbook.Sheets("Setup")
arr(1) = "PAM"
arr(2) = "RL"
For j = 1 To 2
For i = 1 To 16
Me.Controls("Col" & i & arr(j)).Value = (ws.Cells(j + 2, i + 1) = 1)
Next i
Next j
I am:
using the Excel Clean function to strip all formatting off any text, and
then I want to break the resulting long string into separate rows of 80 characters or less.
the only delimiter remaining after the clean is a white space.
The code below does this like a champ but it is brutal;
Code
Sub TrimTo75()
myRow = 4
Range("C" & myRow).Select
myString = ActiveCell.Value
While myString <> ""
While Len(myString) > 75
mySubString = Left(myString, 75)
ActiveCell.Value = mySubString
myString = Right(myString, Len(myString) - 75)
myRow = myRow + 1
Range("C" & myRow).Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
If Len(myString) < 75 Then
ActiveCell.Value = myString
End If
Wend
myRow = myRow + 1
Range("C" & myRow).Select
myString = ActiveCell.Value
Wend
End Sub
Try this ..
Sub TrimTo75()
myRow = 4
Range("C" & myRow).Select
myString = ActiveCell.Value
Dim x As Integer
While myString <> ""
While Len(myString) >= 75
x = 75
While Not Mid(myString, x, 1) = " "
x = x - 1
Wend
MsgBox x
'mySubString = Left(myString, 75)
mySubString = Left(myString, x)
ActiveCell.Value = mySubString
'myString = Right(myString, Len(myString) - 75)
myString = Mid(myString, x + 1)
myRow = myRow + 1
Range("C" & myRow).Select
Application.CutCopyMode = False
Selection.Insert Shift:=xlDown
If Len(myString) < 75 Then
ActiveCell.Value = myString
End If
Wend
myRow = myRow + 1
Range("C" & myRow).Select
myString = ActiveCell.Value
Wend
End Sub
This code uses a Regex and a variant array for quick parsing
It takes a range from C4:Cx and places the chunks in D4 down
Sub QuickStrip()
Dim Regex As Object
Dim RegexMC As Object
Dim RegexM As Object
Dim lngCnt As Long
Dim lngOut As Long
X = Range([c4], Cells(Rows.Count, "C").End(xlUp))
Application.ScreenUpdating = False
Set Regex = CreateObject("vbscript.regexp")
With Regex
.Pattern = "[\w\s]{1,79}([^\w]|$)"
.Global = True
For lngCnt = 1 To UBound(X)
If .test(X(lngCnt, 1)) Then
Set RegexMC = .Execute(X(lngCnt, 1))
For Each RegexM In RegexMC
[d4].Offset(lngOut, 0) = RegexM
lngOut = lngOut + 1
Next
End If
Next
End With
Application.ScreenUpdating = True
End Sub
If Len(rngCellsB_Title) > 90 Then
x = 90
While Not Mid(rngCellsB_Title, x, 1) = " "
x = x - 1
Wend
strFirstPart = Left(rngCellsB_Title, x)
strSecondPart = Right(rngCellsB_Title, (Len(rngCellsB_Title) - x))
blnSplit = True
End If
If blnSplit Then
strMessageTemp = strFirstPart & strSecondPart & Chr(13)
blnSplit = False
Else
strMessageTemp = rngCellsB_Title & Chr(13)
End If
Try this, it simply splits the string before a known point using the space as a demiliter. I used a simple boolean to test for before processing either the whole string, or 2 parts of it.
I am trying to write a macro in Excel which will allow me to automatically do groupings based on the number located in the first column. Here is the code.
Sub Makro1()
Dim maxRow As Integer
Dim row As Integer
Dim groupRow As Integer
Dim depth As Integer
Dim currentDepth As Integer
maxRow = Range("A65536").End(xlUp).row
For row = 1 To maxRow
depth = Cells(row, 1).Value
groupRow = row + 1
currentDepth = Cells(groupRow, 1).Value
If depth >= currentDepth Then
GoTo EndForLoop
End If
Do While currentDepth > depth And groupRow <= maxRow
groupRow = groupRow + 1
currentDepth = Cells(groupRow, 1).Value
Loop
Rows(row + 1 & ":" & groupRow - 1).Select
Selection.Rows.Group
EndForLoop:
Next row
End Sub
The first column in the Excel file looks like this:
1
2
2
3
3
4
4
4
4
5
5
5
6
6
6
6
5
6
6
6
7
8
8
9
10
9
10
10
8
7
7
8
6
5
4
3
2
1
2
When the macro reaches the depth 8 speaking of the groupings, I get error number 1004. It looks like the Excel does not allow me to create a depth greater than 8. Is there a workaround for this? I am using MS Excel 2003.
You are out of luck.
There is an 8 level limit for grouping which
also exists in xl07
on my testing exists in xl2010 (gives "Group method of range class failed")
I wrote this code to hide the sublevel rows, like grouping does.
it needs the first row empty, where the general level buttons will be placed.
it will create a button (placed in the first column) for each node with sublevels.
Clicking on the buttons will hide/unhide the corresponding sublevels.
the check_col is a colum that must be filled up to the last rows (i.e. no blank rows, or the "while" loop will stop
the lvl_col is the column that contains the level index
the start_row is the first row that contains useful data
hope this helps
Sub group_tree()
check_col = "A"
lvl_col = "D"
start_row = 3
Dim btn As Button
Application.ScreenUpdating = False
ActiveSheet.Buttons.Delete
Dim t As Range
'------------Place the buttons on top--------------
i = start_row
e_lvl = 0
b_spac = 0
b_width = 20
b_toggle = 0
While Range(check_col & i) <> ""
lvl = Range(lvl_col & i)
If lvl > e_lvl Then e_lvl = lvl
i = i + 1
Wend
Set t = ActiveSheet.Range("A" & 1)
For c = Range(lvl_col & start_row) To e_lvl
Set btn = ActiveSheet.Buttons.Add(t.Left + b_spac, t.Top, b_width, 10)
With btn
.OnAction = "btnS_t"
.Caption = c
.Name = start_row & "_" & c & "_" & lvl_col & "_" & b_toggle
End With
b_spac = b_spac + 20
Next
'--------------Place the buttons at level---------
i = start_row
While Range(check_col & i) <> ""
lvl = Range(lvl_col & i)
If Range(lvl_col & i + 1) > lvl Then
Set t = ActiveSheet.Range("A" & i)
' Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, b_width, 10)
With btn
.OnAction = "btnS"
.Caption = lvl
.Name = i & "_" & lvl & "_" & lvl_col
End With
End If
i = i + 1
Wend
Application.ScreenUpdating = True
End Sub
Sub btnS()
Dim but_r As Integer
Set b = ActiveSheet.Buttons(Application.Caller)
id_string = b.Name
Dim id() As String
id = Split(id_string, "_")
start_row = CInt(id(0))
start_lvl = CInt(id(1))
lvl_col = id(2)
' MsgBox (lvl_col)
Call hide_rows(start_lvl, start_row, lvl_col)
End Sub
Sub hide_rows(start_lvl, start_row, lvl_col)
a = start_row + 1
While Range(lvl_col & a) > start_lvl
a = a + 1
Wend
If Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = False Then
Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = True
Else
Range(lvl_col & start_row + 1, lvl_col & a - 1).EntireRow.Hidden = False
End If
End Sub
Sub btnS_t()
Dim but_r As Integer
Set b = ActiveSheet.Buttons(Application.Caller)
id_string = b.Name
Dim id() As String
id = Split(id_string, "_")
start_row = CInt(id(0))
start_lvl = CInt(id(1))
lvl_col = id(2)
b_toggle = CInt(id(3))
If b_toggle = 0 Then
b_toggle = 1
Else
b_toggle = 0
End If
b.Name = start_row & "_" & start_lvl & "_" & lvl_col & "_" & b_toggle
Call hide_rows_tot(start_lvl, start_row, lvl_col, b_toggle)
End Sub
Sub hide_rows_tot(start_lvl, start_row, lvl_col, b_toggle)
a = start_row
While Range(lvl_col & a) <> ""
b = a
While Range(lvl_col & b) > start_lvl
b = b + 1
Wend
If b > a Then
If b_toggle = 1 Then
Range(lvl_col & a, lvl_col & b - 1).EntireRow.Hidden = True
Else
Range(lvl_col & a, lvl_col & b - 1).EntireRow.Hidden = False
End If
a = b - 1
End If
a = a + 1
Wend
End Sub