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
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
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.
I ran into a problem when I try to add the first 10 even numbers in a column regardless of the number of inputs someone has entered into said column.
The issue occurs when there are less than 10 inputs (in my case 7) and I have tried to break the loop if there are no more numbers after the last one but it doesn't seem to work as it crashes Excel; most probably because it loops infinitely.
The original code was fine until I entered below 10 even numbers. When I did it would loop infinitely and crash so I inputted a forceful break in the code (hence the Count=999) but it does not seem to work
Sub TenPosInt()
Dim Total As Integer, size As Integer, myRange As range
Dim Count As Integer
Count = 1
Set myRange = range("W:W")
size = WorksheetFunction.CountA(myRange)
While Count <= 10
If IsEmpty(Cells(Count, "W")) Then
Count = 999
End If
If Cells(Count, "W").Value Mod 2 = 0 Then
Total = Total + Cells(Count, "W").Value
Count = Count + 1
End If
Wend
MsgBox Total
End Sub
My Inputs are currently 2,4,6,5,2,4,6,8,1,3,5 so it does not meet the 10 even integers, however I still want it to run regardless (hence the Count=999 line). The correct return should be 32.
A Do-While/Until loop is recommended instead of While-Wend (see this).*
Here I use a separate counter for row and the number of even values (and stole David's idea of combining the two conditions in the Do line).
Sub TenPosInt()
Dim Total As Long, r As Long, Count As Long
r = 1
Do Until Count = 10 Or Cells(r, "W") = vbNullString
If Cells(r, "W").Value Mod 2 = 0 Then
Total = Total + Cells(r, "W").Value
Count = Count + 1
End If
r = r + 1
Loop
MsgBox Total & " (" & Count & " even numbers)"
End Sub
*Actually I would be more inclined to use one of the other gent's answers, but I have tried to stick as close to yours as possible. (Also a good idea to check a cell is numeric before checking for even-ness.)
Just for fun - here is an approach that uses a For...Next loop, allows for non-numeric entries in Column W, and handles the possibility of blank rows between entries.
Sub TenPosInt()
Dim lastRow As Long
lastRow = Cells(Rows.Count, "W").End(xlUp).Row
Dim i As Long
For i = 1 To lastRow
If Not IsEmpty(Cells(i, "W")) Then
If IsNumeric(Cells(i, "W")) Then
If Cells(i, "W").Value Mod 2 = 0 Then
Dim counter As Long
counter = counter + 1
Dim total As Long
total = total + Cells(i, "W").Value
If counter = 10 Then Exit For
End If
End If
End If
Next
MsgBox total
End Sub
Why not use a standard for loop across a range? this would give more specific inputs for the subroutine.
Description of what is occuring below has been commented out to allow for copy/pasting more easily.
'Define your range (you use columns("W"), but narrow that)... assuming you start in row 2 (assumes row 1 is headers), move to the last row, of the same columns:
lr = cells(rows.count,"W").end(xlup).row
'so you know the last row, loop through the rows:
for i = 2 to lr
'Now you will be doing your assessment for each cell in column "W"
if isnumeric(cells(i,"W").value) AND cells(i,"W").value mod 2 = 0 then
s = s + cells(i,"W").value
counter = counter + 1
if counter = 10 then exit for
end if
'Do that for each i, so close the loop
next i
'You now have determined a total of 10 items in the range and have added your items. Print it:
debug.print s
Edit1: got a comment to not break-up the code in an explanatory fashion, so I have added ' to comment out my explanations in an effort to make my coding portion copy/pasteable as a lump.
This is probably a silly question but I cant seem to get it to work, A nice person on here helped me with getting my initial code to work.
However I have been asked for a change and I cant seem to get it to work.
My data comes in two tables so when I use the current code It provides me with the header row in my next table, the only way around this is to look up rows 6-28 and then I need it to jump and look up rows 35-50 (if it looks at anything in between this I get my header row appearing).
I have tried to update the code below to get it to reference these two blocks separately but it doesn't seem to like it.
*****What my raw data looks like*****
*****When I run the current code the results I am getting*****
Below is the code I have tried to alter to get it to look at the two areas separately
Any help would be greatly appreciated.
Sub BUTTON5TEST_Click()
Dim c As Range
Dim d As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
' Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Wheel Diameters")
Set Target = ActiveWorkbook.Worksheets("Wheel Diameters League")
j = 3 ' Start copying to row 3 in target sheet
For i = 1 To 3 'Number of ¿wees?
For Each c In Source.Range(Cells(6, 5 * i - 2), Cells(28, 5 * i + 1))
For Each d In Source.Range(Cells(35, 5 * i - 2), Cells(50, 5 * i + 1))
If c.Text <= 800 Then
Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
Target.Cells(j, 2) = Source.Cells(5, c.Column)
j = j + 1
End If
Next c
Next d
Next i
End Sub
Excuse me, but I still can't get what you want. It would help if 1) your example pictures contains Row numbers and Column letters, and if 2) the results your're showing corresponds to the picture's data (for example 3302). If not we're left guessing too many things. Anyway, I tried a code. Not for responding a question I'm not fully understanding, but trying to move one step forward. Basically, I tried to union your two ranges. Also, you should pay particular atention to the line If c.Text <= 800 Then: it seems odd to check if a string (.text) is less than 800. And finally, make shure that your defined range excludes headings (I guess thats why you are getting those "empty" rows between the 3000's and the 4000's in the results).
Sub BUTTON5TEST_Click()
Dim c As Range
Dim j As Integer
Dim Source As Worksheet
Dim Target As Worksheet
'Change worksheet designations as needed
Set Source = ActiveWorkbook.Worksheets("Wheel Diameters")
Set Target = ActiveWorkbook.Worksheets("Wheel Diameters League")
j = 3 ' Start copying to row 3 in target sheet
For i = 1 To 3 'Number of ¿wees?
For Each c In Union(Source.Range(Cells(6, 5 * i - 2), Cells(28, 5 * i + 1)), Source.Range(Cells(35, 5 * i - 2), Cells(50, 5 * i + 1)))
If c.Text <= 800 Then
Target.Cells(j, 1) = Source.Cells(c.Row, 5 * i - 3)
Target.Cells(j, 2) = Source.Cells(5, c.Column)
j = j + 1
End If
Next c
Next i
End Sub
I want to create a list of all possible percentage splits between different number of stocks (a task required to build a proper investment opportunity set). I was able to create a macro tailored for 3 different inputs (the code is below).
Is it be possible to upgrade that macro so that it will automatically take into consideration the number of inputs (i.e. stock tickers) without the necessity to adjust the code every time? So that if input is 5 tickers instead of 3, it will create the list of all possible splits for 5 tickers?
Spreadsheet layout is simple: in row 1 I have a separate ticker in each column (3 tickers at the moment), and the split is provided below as:
ColumnA ColumnB ColumnC
row1 Ticker1 Ticker2 Ticker3
row2 0 0 100
row3 0 1 99
etc.
Here's what I'm using for 3 inputs:
Sub PercentageSplits()
Dim Lastcol As Integer
Lastcol = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
Sheet1.Cells(1, Lastcol + 1).Value = "Total"
Sheet1.Cells(1, Lastcol + 1).Font.Bold = True
Dim row As Integer: row = 2
Dim i As Integer, j As Integer, k As Integer
For i = 0 To 100: For j = 0 To 100: For k = 0 To 100
If i + j + k = 100 Then
Sheet1.Cells(row, 1).Value = i
Sheet1.Cells(row, 2).Value = j
Sheet1.Cells(row, 3).Value = k
Sheet1.Cells(row, Lastcol + 1).Value = i + j + k
row = row + 1
End If
Next: Next: Next
End Sub
I put a quick program together to calculate these and for a total of 100 split across 5 tickers, I got more than 4.5 million results (4,598,126 to be precise). That's way too many to fit on an Excel sheet.
To make sure that the output would fit on an Excel sheet, I halved the precision by calculating combinations of 5 tickers which added to 50 and then doubling the results. This gives 316,251 results.
If you need full precision then you could adapt the code to output the data in chunks of 1 million rows per worksheet
I don't often use recursion in VBA but it seemed the obvious way to answer this particular question. I'll explain some details below the code:
Option Explicit
' We'll store each result here
Dim splitList As Collection
Sub main()
Dim splitResult As Variant
Dim splitArray As Variant
Dim splitEntry As Variant
Dim outputArray() As Variant
Dim outputRow As Long
Dim outputCol As Long
' Initial set-up
Const TOTAL_TO_SPLIT As Integer = 50
Const NO_OF_TICKERS As Integer = 5
Set splitList = New Collection
' Generate the list
findSplit TOTAL_TO_SPLIT, 1, NO_OF_TICKERS, ""
MsgBox splitList.Count
' Output the list
ReDim outputArray(1 To splitList.Count, 1 To NO_OF_TICKERS)
outputRow = 1
With Worksheets("Sheet1")
.UsedRange.Clear
For Each splitResult In splitList
outputCol = 1
If Len(splitResult) > 0 Then
splitArray = split(splitResult, ";")
For Each splitEntry In splitArray
outputArray(outputRow, outputCol) = splitEntry * 2
outputCol = outputCol + 1
Next splitEntry
End If
outputRow = outputRow + 1
Next splitResult
.Cells(2, 1).Resize(splitList.Count, NO_OF_TICKERS).Value = outputArray
End With
End Sub
' This sub is intended to be called recursively and will add an entry
' to splitList after each recursion concludes
Sub findSplit(amountToSplit As Integer, currentTicker As Integer, _
totalTickers As Integer, resultSoFar As String)
Dim i As Integer
' Call DoEvents to prevent Excel from showing as "Not Responding"
DoEvents
' Check if this is the last ticker
If (currentTicker = totalTickers) Then
splitList.Add resultSoFar & amountToSplit
Else
For i = 0 To amountToSplit
' Otherwise, generate all the possible splits by recursion
findSplit (amountToSplit - i), (currentTicker + 1), _
totalTickers, (resultSoFar & i & ";")
Next i
End If
End Sub
Notes:
this is not going to run quickly. I suggest that you bring up the Locals window (View > Locals window) in the Visual Basic editor before running the macro so you can periodically use Ctrl-Break to check on progress
you could eliminate the collection and just write directly into the 2D array but I was trying to keep the recursive part of the code as simple as possible
It's probably easiest to understand the recursive sub (findSplit) by working backwards. If we are on the final ticker (so currentTicker = totalTickers) then we only have one possibility: the amount left over after all of the previous tickers needs to be allocated to the final ticker.
If we back up a level, if we are on the second-last ticker and the amount left over is 1 then we have two choices. Allocate 0 to the second-last ticker and pass 1 on to the last ticker OR allocate 1 to the second-last ticker and pass 0 on to the last ticker. Extending things to more tickers and/or greater amounts is just a repetition of these same two rules:
if this is the last ticker, allocate whatever's left to this ticker
if this is not the last ticker, try every possible allocation of whatever was left to this ticker and pass whatever is left over on to the next ticker
Each ticker adds the amount it was allocated to a string which is added to the collection by the last ticker. An entry of 14;6;0;13;17 shows that the ticker 1 was allocated 14, ticker 2 was allocated 6 and so on. As stated above, I reduced the number of results by calculating allocations against a total of 50 and then doubled the result. So the 14;6;0;13;17 combination would output as 28;12;0;26;34 (and you'll find it in row 228559 on the output worksheet).
The code in the main sub using Split and the For Each ... Next loops converts the strings stored in the collection into a 2D array of numbers that we can drop directly on to the worksheet