I have the following input data:
I need to populate each entry into 3 rows with different payout rates & periods, something like this:
Thecommission payout is based on the following rates:
i) 1st month - 50%
ii) 2nd month - 30%
iii) 3rd month - 20%
Example:-
The next criteria is the commission payout period. The current month collection will be paid in the following months.
How can I do it using a Excel & macro?
Thanks.
Assuming your data is on the 1st sheet, create a second sheet and run this macro:
Option Explicit
Sub popData()
Dim r As Integer, r2 As Integer, p As Integer: r2 = 3
Dim sht2 As Worksheet: Set sht2 = Sheets(2)
Dim rate(), headings()
rate = Array(0.5, 0.3, 0.2)
headings = Array("Date", "Sales", "Commission", "Collection Date", "Invoice No")
For r = 0 To UBound(headings):
sht2.Cells(2, r + 1).Value = headings(r)
Next
Dim dat As Date
With Sheets(1)
sht2.Cells(1, 1).Value = "Payout"
For r = 3 To .Cells(.Rows.Count, "A").End(xlUp).row:
For p = 0 To 2:
sht2.Cells(r2, "A").NumberFormat = .Cells(r, "A").NumberFormat
dat = DateAdd("m", p + 1, CDate(.Cells(r, "A")))
sht2.Cells(r2, "A").Value = DateSerial(year(dat), month(dat) + 1, 0)
sht2.Cells(r2, "B").Value = .Cells(r, "B").Value
sht2.Cells(r2, "C").NumberFormat = "0.00"
sht2.Cells(r2, "C").Value = .Cells(r, "C").Value * rate(p)
sht2.Cells(r2, "D").NumberFormat = .Cells(r, "A").NumberFormat
sht2.Cells(r2, "D").Value = .Cells(r, "A").Value
sht2.Cells(r2, "E").Value = .Cells(r, "D").Value
r2 = r2 + 1
Next
Next
End With
sht2.Columns("A:E").EntireColumn.AutoFit
End Sub
The first loop adds the headers to the 2nd sheet. The next double loop processes each salesperson with the inner loop creating the 3 rows for each commission payout. It appears that you want the last day of the next month - which is provided for by adding a month to the present date and then using the DateSerial function to find the last day of that month. The last line just ensures all the columns are expanded to their largest text entry so everything is visible.
Related
I would like populate the blue area with random numbers.
sum of C3 to R3 should be equal to B3 value: 124
also;
sum of C3 to C26 should be equal to C2 value: 705
I tried to achieve it with the following code:
(this code was originally posted here: Code by #Mech
Sub RandomNumbersArray()
' dim your variables. this tells vba what type of variable it is working with
Dim lRow As Long
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
' find the last row in column b (2) in the above defined ws
lRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
' loop through rows 3 to last row
For i = 3 To lRow
' generate a random number between 0 and the row contents of column B (5)
ws.Cells(i, 3).Value = Int(Rnd() * (ws.Cells(i, 2).Value + 1))
' generate a random number between 0 and the difference between column B and colum C
ws.Cells(i, 4).Value = Int(Rnd() * (ws.Cells(i, 2).Value - ws.Cells(i, 3).Value))
' subtract the difference between column B and the sum of column C and column D
ws.Cells(i, 5).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value)
' subtract the difference between column B and the sum of column C and column D and column E
ws.Cells(i, 6).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value + ws.Cells(i, 5).Value)
' subtract the difference between column B and the sum of column C and column D and column E and column F
ws.Cells(i, 7).Value = ws.Cells(i, 2).Value - (ws.Cells(i, 3).Value + ws.Cells(i, 4).Value + ws.Cells(i, 5).Value + ws.Cells(i, 6).Value)
Next i
' sum column C (column 3) and place the value in C2
ws.Cells(2, 3).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 3), Cells(lRow, 3)))
' sum column D (column 4) and place the value in D2
ws.Cells(2, 4).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 4), Cells(lRow, 4)))
' sum column E (column 5) and place the value in E2
ws.Cells(2, 5).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 5), Cells(lRow, 5)))
' sum column F (column 6) and place the value in F2
ws.Cells(2, 6).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 6), Cells(lRow, 6)))
' sum column G (column 7) and place the value in F2
ws.Cells(2, 7).Value = Application.WorksheetFunction.Sum(Range(Cells(3, 7), Cells(lRow, 7)))
End Sub
EDIT: Just to clarify, no negative numbers.
Here is something to try:
Set all cells to 0. Create a list of all cells (some kind of reference to each cell).
Now, randomly choose a cell from your list, and add 1 to that cell. The very first time, all cells will be 0, except for one, which will now be 1.
For this cell that you just incremented, add up the row and column and see if the sums have been reached. If either the row or the column sum has been reached, remove this cell reference from the list.
Repeat (randomly choose a cell from those remaining on the list) until the list is empty.
At each iteration you are randomly choosing one of the remaining cells in the reference list (not choosing from all the cells) and this list is getting smaller and smaller as column or row sums are reached.
It should be the case that random cells will increment, and if the columns and sums can in fact be calculated by values without logical inconsistencies, you should fairly quickly reach that point when the reference list falls empty.
I have a solution.
Answers so far have mostly been about finding values which are random, then fixing them to fit the totals.
I tried finding a calculated (non random) solution that fits the totals, then made a separate sub to randomize it. This way you can prevent the randomization from introducing negative values.
There are two procedures, This sub will call them both on the same Range.
Sub Call_Random_Array
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
Dim RangeToFill as Range: Set RangeToFill = ws.Range("C3:R26") 'Edit this line to select whatever range you need to fill randomly
'Proportionately fill the array to fit totals:
Call ProportionateFillArray(RangeToFill)
'Randomize it x times
For x = 1 to 10 'increase this number for more randomisation
Call RandomizeValues(RangeToFill)
Next
End Sub
Proportionately fill the array to fit totals:
Sub ProportionateFillArray(rngAddress As Range)
Dim ws As Worksheet: Set ws = rngAddress.Worksheet
'Horizontal and Vertical target values as ranges:
Dim hTarg As Range, vTarg As Range
Set hTarg = rngAddress.Rows(1).Offset(-1, 0)
Set vTarg = rngAddress.Columns(1).Offset(0, -1)
'Check the totals match
If Not WorksheetFunction.Sum(hTarg) = WorksheetFunction.Sum(vTarg) Then
'totals don't match
MsgBox "Change the targets so both the horizontal and vertical targets add up to the same number."
Exit Sub
End If
With rngAddress
'Now fill rows and columns with integers
Dim Row As Long, Col As Long
For Row = 1 To .Rows.Count
For Col = 1 To .Columns.Count
.Cells(Row, Col) = Int( _
hTarg.Cells(Col) * vTarg.Cells(Row) / WorksheetFunction.Sum(hTarg) _
)
Next
Next
'Correct rounding errors
For Row = 1 To .Rows.Count
For Col = 1 To .Columns.Count
If Row = .Rows.Count Then
'Last row, so this column must be corrected come what may
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Sum(.Columns(Col)) + hTarg.Cells(Col)
ElseIf Col = .Columns.Count Then
'Last column, so must be corrected come what may
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Sum(.Rows(Row)) + vTarg.Cells(Row)
ElseIf _
(WorksheetFunction.Sum(.Rows(Row)) - vTarg.Cells(Row)) * _
(WorksheetFunction.Sum(.Columns(Col)) - hTarg.Cells(Col)) > 0 Then
'both row and column are incorrect in the same direction
.Cells(Row, Col) = .Cells(Row, Col) - WorksheetFunction.Max( _
WorksheetFunction.Sum(.Rows(Row)) - vTarg.Cells(Row), _
WorksheetFunction.Sum(.Columns(Col)) - hTarg.Cells(Col))
End If
Next
Next
End With
End Sub
Randomize an array without changing row or column totals:
Sub RandomizeValues(rngAddress As Range)
Dim ws As Worksheet: Set ws = rngAddress.Worksheet
Dim rngIncrease(1 To 2) As Range, rngDecrease(1 To 2) As Range, lDiff As Long
With rngAddress
'Select two cells to increase at random
For a = 1 To 2
Set rngIncrease(a) = .Cells(RndIntegerBetween(1, .Rows.Count), RndIntegerBetween(1, .Columns.Count))
rngIncrease(a).Select
Next
'Corresponding cells to decrease to make totals the same:
Set rngDecrease(1) = ws.Cells(rngIncrease(1).Row, rngIncrease(2).Column)
Set rngDecrease(2) = ws.Cells(rngIncrease(2).Row, rngIncrease(1).Column)
'Set the value to increase/decrease by - can't be more than the smallest rngDecrease Value, to prevent negative values
If Not WorksheetFunction.Min(rngDecrease) > 1 Then
'Don't decrease a value below 1
Exit Sub
Else
lDiff = RndIntegerBetween(1, WorksheetFunction.Min(rngDecrease)-1)
End If
'Now apply the edits
For a = 1 To 2
rngIncrease(a) = rngIncrease(a) + lDiff
rngDecrease(a) = rngDecrease(a) - lDiff
Next
End With
End Sub
'The below is the Random Integer function, I also used it in my other answer
Function RndIntegerBetween(Min As Long, Max As Long) As Long
RndIntegerBetween = Int((Max - Min + 1) * Rnd + Min)
End Function
This code is for what you were trying to do, not exactly how you explained it though (see comments). If this is what you were looking for, then your explanation was a bit off, otherwise let me know what you did mean.
Sub RandomNumbersArray()
Dim lRow As Long, lColumn As Long, remainingValue As Long
Dim wb As Workbook: Set wb = ActiveWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets("SPLIT BY DAYS")
lRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
lColumn = ws.Cells(2, ws.Columns.Count).End(xlToLeft).Column
For i = 3 To lRow 'loop through the rows
remainingValue = ws.Cells(i, 2).Value2
For j = 3 To lColumn 'loop through all the columns per row
' generate a random number between 0 and the row contents of column B - previous column
If j = lColumn Then 'last cell can't be random unless you want to extend the columns until the sum in B-column is met
ws.Cells(i, j).Value2 = remainingValue
Else
ws.Cells(i, j).Value2 = Int((remainingValue + 1) * Rnd)
End If
remainingValue = remainingValue - ws.Cells(i, j).Value2
Next j
Next i
For j = 3 To lColumn 'loop through the columns to set the sum
ws.Cells(2, j).Value2 = Application.WorksheetFunction.Sum(Range(Cells(3, j), Cells(lRow, j)))
Next j
End Sub
I'm yet to get past the O-column with any value above 0 however
I am trying to create a pricing sheet which will import a CSV BOM from Creo into a new worksheet, I have that part sorted. The problem is the next part i want...
We have different values in column 'G' which are for the different materials e.g: 'MS', 'SS', 'ANGLE', 'PURCHASED'
The issue I have is creating a 'total cost' in column 'J' which is based on the material in 'G'. If the value is "MS" then the value in Column 'J' should be quantity x unit mass x material cost.
'Quantity' is the value in column C, 'unit mass' is the value in column E and 'material cost' is always cell H5 in worksheet named 'MASTER' (this is where the total cost column J should be driven from)
Sub subMultiply()
For Each Cel In Range("G2:D" & Cells(Rows.Count, "G").End(xlUp).Row)
If Cel.Value = "MS" Then
Cel.Offset(0, 3).Value = Cel.Offset(0, -2).Value * ThisWorkbook.Sheets(MASTER).Range(H5).Value * Cel.Offset(0, -4).Value
ElseIf Cel.Value = "PURCHASED" Then
Cel.Offset(0, 3).Value = Cel.Offset(0, -3).Value * ThisWorkbook.Sheets(MASTER).Range(H6).Value * Cel.Offset(0, -4).Value
End If
Next
End Sub
You should try with the select case function
SOmething like :
Select Case Cells(i, 7)
Case Is = "MS"
Cells(i, 10) = 3
Case Is = "SS"
Cells(i, 10) = 5
Case Is = "ANGLE"
Cells(i, 10) = 8
Case Is = "PURCHASED"
Cells(i, 10) = 11
End Select
Instead of the numbers (3,5,8 and11) I used for my test, you can use whatever you want.
You can use the sheets function to select sheets :
Sheets("MASTER").Cells(5,8) is H5 on the Master Sheets.
Ex : Sheets("Sheet2").Cells(1, 1).Select
'''
Firstrow = .UsedRange.Cells(1).Row
lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For lRow = lastrow To Firstrow Step -1
Set ws2 = ThisWorkbook.Sheets("MASTER")
With .Cells(lRow, "G")
If Not IsError(.Value) Then
If .Value Like ("*MS*") Then Cells(lRow, "D").Value = Cells(lRow, "E").Value * ws2.Range("H5").Value
'''
I was able to add another If statement for each type of material
I have a table with Ticker Symbols (A), workdays over the course of a year (B), opening value (C), high value (D), low value (E), closing value (F), and volume (E). The data is chronological by workday and alphabetical by Ticker Symbol.
I am trying to create in the second sub a command that pulls the first and last row numbers with matching ticker symbols. Then using those row numbers, pull the corresponding opening and closing values for the year to create a yearly change column. I don't get any errors from my code, but the yearly change is not pulling the correct value. What am I missing?
Sub TickerVolume()
' Set an initial variable for holding the ticker
Dim Ticker As String
'Create new column headers
Cells(1, 9).Value = "Ticker"
Cells(1, 10).Value = "Yearly Change"
Cells(1, 11).Value = "Percent Change"
Cells(1, 12).Value = "Total Stock Volume"
' Set an initial variable for holding the volume total
Dim Vol_Total As Double
Vol_Total = 0
' Keep track of the location for summary table
Dim Summary_Table_Row As Integer
Summary_Table_Row = 2
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
' Loop through all tickers
For i = 2 To LastRow
' Check if we are still within the same ticker, if it is not...
If Cells(i + 1, 1).Value <> Cells(i, 1).Value Then
' Set the Ticker
Ticker = Cells(i, 1).Value
' Add to the Volume Total
Vol_Total = Vol_Total + Cells(i, 7).Value
' Print the Ticker in the Summary Table
Range("I" & Summary_Table_Row).Value = Ticker
' Print the Vol to the Summary Table
Range("L" & Summary_Table_Row).Value = Vol_Total
' Add one to the summary table row for next ticker
Summary_Table_Row = Summary_Table_Row + 1
' Reset the Vol Total
Vol_Total = 0
' If the cell immediately following a row is the same Ticker...
Else
' Add to the Ticker Total
Vol_Total = Vol_Total + Cells(i, 7).Value
End If
Next i
End Sub
Sub YearlyChange()
' Find start and end rows with unique Ticker
Dim TickStartRow As Long
Dim TickEndRow As Long
Dim Summary_Table_Row As Integer
Summary_Table_Row = 2
LastRow1 = Cells(Rows.Count, 9).End(xlUp).Row
' Loop through all tickers
For i = 2 To LastRow1
'Find start and end rows
TickStartRow = Range("A:A").Find(what:=Cells(i, 9), after:=Cells(1,
1)).Row
TickEndRow = Range("A:A").Find(what:=Cells(i, 9), after:=Cells(1, 1),
SearchDirection:=xlPreivous).Row
' Print the Change in the Summary Table
Range("J" & Summary_Table_Row).Value = Range("C" & TickStartRow).Value -
Range("F" & TickEndRow).Value
' Add one to the summary table row for next ticker
Summary_Table_Row = Summary_Table_Row + 1
Next i
End Sub
Your problem is probably that in
TickEndRow = Range("A:A").Find(what:=Cells(i, 9), after:=Cells(1, 1), SearchDirection:=xlPreivous).Row
you've spelled xlPrevious incorrectly and without Option Explicit the compiler is just assuming an empty variable for what you've called xlPreivous. Adding Option Explicit to the top of your module code will help catch small typo errors like this. Try correcting that and see what you get.
I have a sheet that I collect the webpage data with columns from A:F
I want to put the old data in column E, from T column and onwards for each time I run the VBA module
I did for now something like
wks.Cells(i, "T").Value = wks.Cells(i, "E").Value
How can I make it to advace each time?
The full code is the following
For i = 2 To 17
LRandomNumber = Int((15 - 2 + 1) * Rnd + 2)
mylink = wks.Cells(i, 2).Value
ie.Navigate mylink
While ie.Busy Or ie.ReadyState < 4: DoEvents: Wend
t = Timer
Do
DoEvents
On Error Resume Next
wks.Range(Cells(i, 1), Cells(i, 5)).Interior.ColorIndex = 38
Set price = ie.Document.querySelector(".price-container .final-price")
myprice = CCur(price.innerText)
checkprice = myprice * 1.24
'FORMAT PRICE
If wks.Cells(i, "E").Value < checkprice Then wks.Cells(i, "E").Interior.ColorIndex = 3 Else wks.Cells(i, "E").Interior.ColorIndex = 4
wks.Cells(i, "E").Value = myprice * 1.24
Set availability = ie.Document.querySelector(".inner-box-one .availability")
wks.Cells(i, "D").Value = availability.innerText
Set product_name = ie.Document.querySelector(".title-container h1.title")
wks.Cells(i, "C").Value = product_name.innerText
If Timer - t > LRandomNumber Then Exit Do
On Error GoTo 0
Loop
If price Is Nothing Then Exit Sub
wks.Range(Cells(i, 1), Cells(i, 5)).Interior.ColorIndex = 0
Next i
We need to put
'COPY PRICE
Call TransferDataFromColumnE(wks)
Outside the For loop
Untested, but I think you could determine the last column containing data by:
Dim lastColumn as long
lastColumn = wks.cells(1, wks.columns.count).end(xltoleft).column
lastColumn = application.max(lastColumn + 1, wks.columns("T").column)
' The Application.Max is meant to guarantee you either write to column T or any column to the right of it.
' +1 is so that we don't overwrite the last column, but instead write to the column after it.
Then you could continue with your code (although it might be better/quicker to assign the entire range/column in one go rather than each cell/row individually).
wks.Cells(i, lastColumn).Value = wks.Cells(i, "E").Value
Edit: Here's a tested example. Say I have some data in column E starting on row 2 on a sheet called "Sheet2".
I can use the code below to copy-paste it to the last column (where the last column is either column T or the first empty column to the right of it).
Option Explicit
Sub TransferDataFromColumnE()
Dim wks As Worksheet
Set wks = ThisWorkbook.Worksheets("Sheet2")
Dim lastColumn As Long
lastColumn = wks.Cells(2, wks.Columns.Count).End(xlToLeft).Column
lastColumn = Application.Max(lastColumn + 1, wks.Columns("T").Column)
With wks.Range("E2:E24") ' This is the range I need to copy in my case
Dim columnOffset As Long
columnOffset = lastColumn - .Columns(1).Column
.Copy
.Offset(0, columnOffset).PasteSpecial xlPasteValuesAndNumberFormats
Application.CutCopyMode = False
End With
End Sub
And this is what I get after I've run the code three times -- which I think is what you want.
I am using a macro from this thread to insert new rows
but the problem is when there is the same start date as end date I get the
Error 1004
can you help modify the VBA to skip those lines that produce the Error?
is there an easy way how to fill in the column B (marked red) the consequential dates to complete the table (one day per line)?
Start Date End Date Hours Type
02-01-18 02-01-18 8 one day
04-01-18 04-01-18 4 half day
05-01-18 06-01-18 16 multiple days
07-01-18 10-01-18 16 multiple days
11-01-18 11-01-18 8 one day
UPDATE:
you can use an if command to check to see if the dates match, then only run the check if they dont. the code will now add every subsequent date between the start and end date
Public Sub AAA_Format()
Dim i As Long
Dim d As Long
Dim LastRow As Long
Dim j As Long
Dim rng As Range, rng2 As Range
Dim startrow As Long, insertedrow As Long
Application.CutCopyMode = False
With Worksheets("Data")
LastRow = .UsedRange.Rows.Count
For i = LastRow To 2 Step -1 '' starts at bottom and goes up, that way inserting rows doesn impact it
'checks to see if 2 values are the same
If Not Cells(i, "B") = Cells(i, "C") Then
Debug.Print Cells(i, "B")
Debug.Print Cells(i, "C")
d = DateDiff("d", .Cells(i, "B"), .Cells(i, "C")) '' find differene
Debug.Print d
insertedrow = i + d
.Rows(i + 1 & ":" & insertedrow).Insert Shift:=xlDown
End If
For j = 1 To d
.Cells(i + j, 2) = .Cells((i + j) - 1, 2) + 1
.Cells(i + j, 3) = "what ever you want to calc end date as"
.Cells(i + j, 4) = "what ever you want to calc hours as"
.Cells(i + j, 5) = "what ever you want to calc day as"
Next j
Next i
End With
End Sub
To insert a column you can use
ActiveSheet.Range("D:D").EntireColumn.Insert
and to add formula to it you can use
LastRow = ActiveSheet.Range("B" & ActiveSheet.Rows.Count).End(xlUp).Row '' this find bottom row by starting on very last row of sheet and moving up until it finds a cell with a value in it
Range("D2").Formula = "=IF(C2>0,C2,C1+1)"'' you might need to change , for ; depending on your language pack
Range("D2:D" & LastRow ).FillDown