can anyone please do this example for me i`m stuck here for about 2 days and cant do it :(
I need to make a code which will write numbers in this pyramidal way: 1 121 12321 1234321.. and must be written as example at this picture
Try this in a worksheet code
Public Sub MakePyramid()
Dim r_start As Range
Set r_start = Range("A1")
Dim i As Long, j As Long, n As Long
n = 3 ' Number of layers
For i = 1 To n
For j = 1 To i
r_start.Cells(2 * i - j, j).Value = j
r_start.Cells(j, 2 * i - j).Value = j
Next j
Next i
End Sub
Result
But why?
You need to figure out why this code works in order to prepare for your exam.
Related
good evening, im quite a long lurker here but i have ran into an issue i cant seem to find a solution for. i have no idea if i post this correctly as i dont have any base code to provide because im not sure if it is possible at all in VBA.
i have a list with values that is variable in size and the induvidual values range from 1 to 33. (this is based on pallet amounts in trucks) what i would like to be able to do is select that range and have a vba code sort out the best way to sum up my values to 33 (But never ever over 33!) and create an array with the values and move on to the next "set" and put the next values that add to 33 in a new array. i know how to do it chronically (thanks to another user here on stackoverflow) but that would mean that it isnt the most efficient option.
lets say i have a list of 5 different values:
10
15
8
22
19
this would create the following "sets":
25
30
19
but if the order of the 5 values would change to:
19
22
15
10
8
it would create the following sets:
19
22
15
18
now i have found a way to define a variable to the optimal number of trucks the code should create, but with the second list it would result in an error if the code i have now goes through that list chronically.
so to summarize, is it possible to create a code that would look at a selection of values and decide what the best most efficient way is of combining values the closest to 33.
ill provide the code i have now, please note it is not at all finished yet and very basic as its just the start of my project and pretty much the core feature of what i want to achieve. if i need to provide more info or details please let me know
thanks in advance. and many thanks to a huge group of people here who unbeknownst to themselves have already helped me save hours upon hours of work by providing their solutions to problems i had but didnt need to ask
here is my code:
Sub test()
Dim ref, b As Range
Dim volume, i As Integer
Dim test1(), check, total As Double
Dim c As Long
Set ref = Selection
volume = ref.Cells.Count
c = ref.Column
ReDim test1(1 To volume)
'this creates a total of all the values i select
For Each b In ref
total = total + b
Next b
'this determines when to round up or down
check = total / 33 - Application.WorksheetFunction.RoundDown(total / 33, 0)
If check < 0.6 Then
total = Application.WorksheetFunction.RoundDown(total / 33, 0)
Else
total = Application.WorksheetFunction.RoundUp(total / 33, 0)
End If
'this creates an array with all the values
i = 1
Do Until i = volume + 1
test1(i) = Cells(i, c).Value
i = i + 1
Loop
'this is just a way for me to check and verify my current part of the code
MsgBox (Round(test1(8), 2))
MsgBox (total)
End Sub
You can change the cell result location as per your wish. I am showing the result in the immediate window.
Sub test()
Dim CellsCount As Integer
CellsCount = Selection.Cells.Count
Dim i, j As Long
Dim x, y As Long
Dim SumLoop As Long
SumLoop = 0
x = 1
y = 1
For i = x To CellsCount
Do
For j = y To CellsCount
SumLoop = SumLoop + Selection.Cells(j).Value
If SumLoop < 33 Then
Debug.Print SumLoop
y = j + 1
If y = CellsCount + 1 Then Exit Sub
Else
SumLoop = 0
x = j
y = j
Exit For
End If
Next
Loop While SumLoop < 33
Next
End Sub
This is a straight brute force, checking every single combination, if your set gets too big this will slow way down but it was <1 second on a set of 1,000.
I loaded values into Column A. Outputs the lowest amount of trucks you need.
You can probably reduce the amount of variables by using a type or class but wanted to keep it relatively simple.
Dim i As Long
Dim lr As Long
Dim limit As Long
Dim count As Long
Dim sets As Long
Dim best As Long
Dim start As Long
Dim addset As Boolean
Dim loopcounter As Long
limit = 33
With Sheets("Sheet1")
lr = .Cells(.Rows.count, 1).End(xlUp).Row
Dim arr() As Long
ReDim arr(0 To lr - 2)
For i = 2 To lr
arr(i - 2) = .Cells(i, 1).Value 'Load array
Next i
start = 0
i = start
Do
If count + arr(i) <= limit Then
count = count + arr(i)
addset = False 'Just for tracking the final set
Else
addset = True
sets = sets + 1
count = arr(i)
End If
i = i + 1
If i > UBound(arr) Then
i = 0 'reset index
End If
loopcounter = loopcounter + 1 'tracking items in set
If loopcounter > UBound(arr) Then
If addset = False Then
sets = sets + 1 'adding final set if not already added
End If
Debug.Print start, sets
If best > sets Or best = 0 Then
best = sets 'Get the lowest value
End If
'resetting values
loopcounter = 0
sets = 0
start = start + 1
i = start
If start > UBound(arr) Then
Exit Do
End If
End If
Loop
End With
Debug.Print best
I'm sure this is explained somewhere but I can't seem to find out what I should search for.
I'm writing some code that lets the user input a number and the code should then do certain tasks that number of times. I only want to do this task to be done at a maximum of columns per row (lets say 10). Then start at the next row.
Right now I have a nested loop but I can't find a way to make it work with only one loop, instead I've had to create one loop for all rows that's complete (10 columns long) and then a single loop for the last row.
For i = 0 to numberOfCompleteRows
For j = 0 to numberOfColumns
tasks(j,i)
next j
next i
For x = 0 to numberOfColumnsAtLastRow
tasks(x,i+1)
next i
Is there a better way to do this?
(Sorry if there's some small errors in here, my actual code is not written for excel so didn't find a reason to post it as it was, tried to make it as standard as possible.)
If you loop from 1 to the TotalNumberOfRows, then the current column calculates as
CurrentColumn = (iRow - 1) \ NumberOfRowsPerColumn + 1
and the current row calculates as
CurrentRow = iRow - NumberOfRowsPerColumn * (CurrentColumn - 1)
Note that I used the \ Operator which is actually used to divide
two numbers and return an integer result and no normal division that
would use the normal / Operatior and return a floating-point
result.
So you end up with something like
Option Explicit
Public Sub WriteNumbersColumnWise()
Const TotalNumberOfRows As Long = 45
Const NumberOfRowsPerColumn As Long = 10
Dim iRow As Long
For iRow = 1 To TotalNumberOfRows
Dim CurrentColumn As Long
CurrentColumn = (iRow - 1) \ NumberOfRowsPerColumn + 1
Dim CurrentRow As Long
CurrentRow = iRow - NumberOfRowsPerColumn * (CurrentColumn - 1)
Cells(CurrentRow, CurrentColumn).Value = iRow
Next iRow
End Sub
To get the following output
I have to fill about 2k rows in excel which would hurt my brain to do it manually... But after 4hours of searching and trying to solve this problem I'm really close to give it up.
Here is a simple example: A101.0 which is used as a code for a position. The .0 is going to .0 to .6, then the 01 should increase by 1 to look like A102.0 and so on. The 01 which is before the . is going to 57 so the last would look like A157.6. And after this the number near the A should go up to 2, like this. A201.0 and starting over the cycle again.
The very last should looks like this: A657.6
So A is fix, first number is going 1 to 6, the 2 next to it is going 01 to 57 for every "1 to 6" and the last number after the dot is going 0 to 6 for every "01 to 57" number.
I wrote a little macro but not working so well...
Sub Makro1()
Dim i As Integer
Dim j As Integer
Dim k As Integer
For k = 1 To 6
For j = 1 To 57
For i = 1 To 7
Munka1.Cells(i * j * k, 10).Value = "A" & k & j & i - 1
Next i
Next j
Next k
End Sub
If there is any solution whithout vba it would be good also.
I think your macro is fine, it's just this: i * j * k that is bad. Multiplying those numbers together is not going to give you an integer that corresponds to an excel row. Instead you'll need one more variable to track the row to which you write the incremented value:
Sub Makro1()
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim writeRow as Integer
writeRow = 1
For k = 1 To 6
For j = 1 To 57
For i = 1 To 7
Munka1.Cells(writeRow, 10).Value = "A" & k & j & "." & i - 1
writeRow = writeRow + 1
Next i
Next j
Next k
End Sub
Updated to add: I also stuck a & "." & in there to include the decimal in your outputted string location value.
If you have Excel O365 with the SEQUENCE function, you can enter, in a single cell, the formula:
=TEXT((INT(SEQUENCE(6*57*7,,0)/(57*7))+1)*100+(MOD(INT(SEQUENCE(6*57*7,,1,1/7))-1,57)+1)+MOD( SEQUENCE(6*57*7,,0),7)/10,"A000.0")
and it will spill down to create the series you describe.
I think this will give you what you want. Stringing numbers together the way you are is going to cause problems when k jumps from 9 to 10 as the k string is now 2 digits:
You can build the number numerically instead and then force it into a format of your choosing:
Sub Makro1()
Dim i As Long, j As Long, k As Long, y As Long
y = 1 ' y is used as the writing pointer
For k = 1 To 6
For j = 1 To 57
For i = 0 To 6
Munka1.Cells(y, 10).Value = "A" & Format((k * 100) + j + (i / 10), "000.0")
y = y + 1
Next i
Next j
Next k
End Sub
Finally, if you really wanted to concatenate your numbers instead of using math(s), you could use:
Munka1.Cells(y, 10).Value = "A" & k & Right("0" & j, 2) & "." & i
"If there is any solution whithout vba it would be good also."
Instead of VBA, you could use the following formula in A1 and drag down:
=IF(ROUNDUP(ROW()/399,0)>6,"","A"&ROUNDUP(ROW()/399,0)&TEXT(MOD(ROUNDUP(ROW()/7,0)-1,57)+1,"00")&"."&MOD(ROW(A1)-1,7))
I stuck the IF in there to start showing blanks after A657.6 or rather, row 2395.
I have a dynamic population of tasks that I receive monthly, I want to assign these tasks to 6 groups for them to assess in an evenly distributed fashion. Each task has a ranking/priority, so if a group receives the number 1 task, I don't want to also give that same group the top 100 priorities. I want to apply a snaking/zigzag distribution.
This led me down a path to using the formula =MIN(MOD(ROW()-2,12),MOD(-ROW()+1,12)). I get the distribution I'm looking for, although at this stage I don't know how to account for any criteria that I need to add into my logic.
In the above image I am trying to take the groups in column F and apply them to Column D. Column E shows the example of the =MOD() formula and I could just use a lookup to replace the Mod values of 0-5 with my groups 1-6.
Where I hit a roadblock is in row 21, which is where I want to account for some criteria, or exceptions. I added a binary column A for visualization, but essentially, I want to say where column C (task location) = Loc4 to never assign a task to Group 4. In the instance where I don't want a task to be assigned to Group 4 at Loc 4, I then hope to skip Group 4 for a single assignment until it can be applied to the next possible ranked task. The simple solution is to remove all these occurrences at the end, but it really skews the even distribution I'm going for.
I tried to apply solver to this assignment, looking for the lowest std deviation, but I have too many data points.
This has led me to another post using some vba logic, which I really like the concept, but I cannot figure out how to modify it to account for some exceptions. enter link description here
Ideally I would love to use this concept of creating a single array of my groups, applying each group to a task as long as the criteria is met in this short list of task, write the groups into the list, reset and move down to the next subset of tasks. So, each time I select the next 6 tasks, they are assigned to one of my 6 groups, which will keep the distribution that I'm hoping for.
Here is the code from the user K.Davis post which I was trying to apply:
Sub assignEmployeeTasks()
Dim ws As Worksheet, i As Long
Set ws = ThisWorkbook.Worksheets(1)
Dim employeeList() As Variant
With ws
For i = 2 To lastRow(ws, 2)
If (Not employeeList) = -1 Then
'rebuild employeelist / array uninitialized
employeeList = buildOneDimArr(ws, "F", 2, lastRow(ws, "F"))
End If
.Cells(i, 4) = randomEmployee(employeeList)
Next
End With
End Sub
These are the "support" functions that allow your program to do it's job:
Function randomEmployee(ByRef employeeList As Variant) As String
'Random # that will determine the employee chosen
Dim Lotto As Long
Lotto = randomNumber(LBound(employeeList), UBound(employeeList))
randomEmployee = employeeList(Lotto)
'Remove the employee from the original array before returning it to the sub
Dim retArr() As Variant, i&, x&, numRem&
numRem = UBound(employeeList) - 1
If numRem = -1 Then 'array is empty
Erase employeeList
Exit Function
End If
ReDim retArr(numRem)
For i = 0 To UBound(employeeList)
If i <> Lotto Then
retArr(x) = employeeList(i)
x = x + 1
End If
Next i
Erase employeeList
employeeList = retArr
End Function
' This will take your column of employees and place them in a 1-D array
Function buildOneDimArr(ByVal ws As Worksheet, ByVal Col As Variant, _
ByVal rowStart As Long, ByVal rowEnd As Long) As Variant()
Dim numElements As Long, i As Long, x As Long, retArr()
numElements = rowEnd - rowStart
ReDim retArr(numElements)
For i = rowStart To rowEnd
retArr(x) = ws.Cells(i, Col)
x = x + 1
Next i
buildOneDimArr = retArr
End Function
' This outputs a random number so you can randomly assign your employee
Function randomNumber(ByVal lngMin&, ByVal lngMax&) As Long
'Courtesy of https://stackoverflow.com/a/22628599/5781745
Randomize
randomNumber = Int((lngMax - lngMin + 1) * Rnd + lngMin)
End Function
' This gets the last row of any column you specify in the arguments
Function lastRow(ws As Worksheet, Col As Variant) As Long
lastRow = ws.Cells(ws.Rows.Count, Col).End(xlUp).Row
End Function
Any help would be much appreciated! I'm up for any path that gets closer to my desired solution, formulas or vba. Please let me know if you have any questions.
Thanks!
This program works on a block of tasks at a time where the block size is a multiple of the group count. I have SIZE=2 to give a block size of 12 as this gives more opportunity to resolve conflicts than 6 would. It works by initially assigning the tasks to a zigzap pattern and then validates this against the rules you define. These are in the module validLocn(). If the validation is OK the process moves down the sheet to the next block. If the validation fails the plan is shuffled by swapping 2 element randomly chosen and validation retried. This continues up the maximum number set by MAXTRY. If still not resolved the user can chose to retry again, ignore and move on or abort the process. I have tested it with 150,000 records and it took less than a minute, but my test data may not represent your real data. The results in a pivot table on cols B,C,D show even distribution and no tasks for Grp4 at Locn4.
Count of Task
Row Loc1 Loc2 Loc3 Loc4 Loc5 Loc6 Gand Total
Gp1 4013 3975 3926 5082 3986 4018 25000
Gp2 4021 3992 4077 4928 3975 4007 25000
Gp3 3976 3952 4027 5023 4049 3973 25000
Gp4 5050 4915 4936 5035 5064 25000
Gp5 4072 3996 4034 4890 3969 4039 25000
Gp6 3964 4087 3986 5018 3996 3949 25000
Grand 25096 24917 24986 24941 25010 25050 150000
Hope that helps.
Option Explicit
Sub assignEmployeeTasks()
Dim ws As Worksheet, t0 As Single, t1 As Single
Set ws = ThisWorkbook.Sheets("Sheet1")
t0 = Timer
Const COL_GROUP = "F"
Const COL_LOCN = "C"
Const SIZE As Integer = 2 ' plan size = 2 * group count
Const MAXTRY = 50 ' no of tries to validate
Dim bOK As Boolean
Dim grp As Variant, iBlockStart As Long, i As Integer, r As Integer, step As Integer
'initialize grps and location
Dim countGrp As Integer, lastLocn As Long
lastLocn = ws.Range(COL_LOCN & Rows.Count).End(xlUp).Row
countGrp = ws.Range(COL_GROUP & Rows.Count).End(xlUp).Row - 1
grp = ws.Range(COL_GROUP & "2").Resize(countGrp, 1).Value
Dim plan() As String
ReDim plan(countGrp * SIZE, 2)
Dim itry As Integer, res
iBlockStart = 1
Do While iBlockStart < lastLocn
' initialize plan
Call zigzag(plan, grp)
For i = 1 To UBound(plan)
plan(i, 1) = ws.Range("C" & iBlockStart + i).Value
Next
' save 1st attempt
For i = 1 To UBound(plan)
ws.Range("D" & iBlockStart + i).Value = plan(i, 2)
Next
' validate
bOK = validLocn(plan, 0)
retry:
' retry to validate
itry = 0
While bOK = False And itry < MAXTRY
Call shuffle(plan, 1)
bOK = validLocn(plan, itry)
itry = itry + 1
Wend
' write new plan to sheet
For i = 1 To UBound(plan)
ws.Range("D" & iBlockStart + i).Value = plan(i, 2)
Next
' check rule again
If itry = MAXTRY Then
ws.Range(COL_LOCN & iBlockStart).Select
res = MsgBox("Failed to vaidate after " & MAXTRY & " attempts", vbAbortRetryIgnore, iBlockStart)
If res = vbRetry Then GoTo retry
If res = vbAbort Then Exit Sub
End If
iBlockStart = iBlockStart + UBound(plan)
Loop
t1 = Timer
MsgBox "Assigned " & lastLocn - 1 & " tasks in " & Int(t1 - t0) & " secs"
End Sub
' valid plan against rules
Function validLocn(plan As Variant, itry) As Boolean
Dim sLocn As String, sGrp As String, i As Integer
validLocn = True
For i = 1 To UBound(plan)
sLocn = plan(i, 1)
sGrp = plan(i, 2)
' rule 1
If sGrp = "Gp4" And sLocn = "Loc4" Then
validLocn = False
'Debug.Print itry, i, "Fail Rule 1", sGrp, sLocn
Else
'Debug.Print itry, i, "Pass Rule 1", sGrp, sLocn
End If
Next
End Function
' populate plan groups
Sub zigzag(plan As Variant, grp As Variant)
Dim i As Integer, r As Integer, step As Integer
r = 1: step = 1
For i = 1 To UBound(plan)
plan(i, 2) = grp(r, 1)
r = r + step
If r > UBound(grp) Then
r = UBound(grp)
step = -1
ElseIf r < 1 Then
r = 1
step = 1
End If
Next
End Sub
' shuffle plan
Sub shuffle(plan As Variant, i As Integer)
Dim tmp As String, n As Integer, j As Integer, k As Integer
For n = 1 To i
' random choose elements to shuffle
retry:
k = Int(1 + Rnd() * UBound(plan))
j = Int(1 + Rnd() * UBound(plan))
If k = j Then GoTo retry
tmp = plan(k, 2)
plan(k, 2) = plan(j, 2)
plan(j, 2) = tmp
Next
End Sub
' generate test data
Sub testdata()
Dim ws As Worksheet, i As Long
Set ws = ThisWorkbook.Sheets("Sheet1")
For i = 2 To 150001
ws.Cells(i, 2) = i - 1
ws.Cells(i, 3) = "Loc" & 1 + Int(Rnd() * 6)
Next
End Sub
I need to reformat a 33500 row of data in excel. I am trying to write a macro that would do this for me.
I have put some nested loop to solve the issue
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim K As Integer
Dim p As Integer
Dim c As Integer
For c = 0 To 10
For n = 5 To 10
K = 14 + 7 * (n - 5)
For i = 0 To 7
m = 14 + 8 * c
ActiveSheet.Cells(m + i, n).Select
Selection.Copy
ActiveSheet.Cells(K + i, 37).Select
ActiveSheet.Paste
Next i
Next n
Next c
I am stuck at how to get this operation done for 32500 rows
Excel's Integer has a range of values from -32,768 to 32,767 so formatting 33,500 rows might be a problem. Assuming that you are happy with how your code works, changing your variable types to Long might be a good start.
BTW, you should avoid SELECTing cells as it slows down the code and can lead to errors. You can easily copy and paste between cells using soemthing like
Cells(m + i, n).Copy Destination:=Cells(K + i, 37)
Revised the code according to the comment and now working like a charm. Thank you so much
Dim i As Integer
Dim m As Integer
Dim n As Integer
Dim K As Integer
Dim p As Integer
For i = 0 To 121
m = 14
For n = 5 To 35
ActiveSheet.Range(Cells(m + i * 8, n), Cells(m + i * 8 + 7, n)).Copy
Range("AK" & Rows.Count).End(xlUp).Offset(1).PasteSpecial xlValues
Next n
Next i
End Sub