I have a lot of rows of data in Excel, each one corresponds to a product. So for example, my first row is "Lady's Black Dress" and then it has in another cell, sizes separated by commas and also colours in one cell too.
Title Size Colour Price Before Price After
Ladies Dress S,M,L,XL,XXL Blue, Black, Red 19.99 29.99
Men's Trousers S,M,L,XL,XXL Brown, Yellow, Orange 39.99 59.99
hj
So what I need is a VBA that creates a unique row (SKU, essentially) for each product variaton, so my data then looks like this:
I did ask this question before but only for 2 columns, a kind soul provided this VBA which does work, but I need the other columns. I don't quite understand how to adapt this VBA and was changing the letter "B" to "E" but this doesn't seem to work.
Option Explicit
Sub sizeExpansion()
Dim i As Long, szs As Variant
With Worksheets("sheet1")
For i = .Cells(.Rows.Count, "B").End(xlUp).Row To 2 Step -1
szs = Split(.Cells(i, "B").Value2, ",")
If CBool(UBound(szs)) Then
.Cells(i, "A").Resize(UBound(szs), 1).EntireRow.Insert
.Cells(i, "A").Resize(UBound(szs) + 1, 1) = .Cells(UBound(szs) + i, "A").Value2
.Cells(i, "B").Resize(UBound(szs) + 1, 1) = Application.Transpose(szs)
End If
Next i
End With
End Sub
Try this modification with an additional split variant and some maths adjustment.
Option Explicit
Sub sizeAndColorExpansion()
Dim i As Long, s As Long, c As Long
Dim ttl As String, pb As Double, pa As Double
Dim szs As Variant, clr As Variant
With Worksheets("sheet1")
For i = .Cells(.Rows.Count, "E").End(xlUp).Row To 2 Step -1
ttl = .Cells(i, "A").Value2
pb = .Cells(i, "D").Value2
pa = .Cells(i, "E").Value2
szs = Split(.Cells(i, "B").Value2, ",")
clr = Split(.Cells(i, "C").Value2, ",")
If CBool(UBound(szs)) Or CBool(UBound(clr)) Then
.Cells(i, "A").Resize((UBound(szs) + 1) * (UBound(clr) + 1) - 1, 1).EntireRow.Insert
For s = 0 To UBound(szs)
For c = 0 To UBound(clr)
.Cells(i + (s * (UBound(clr) + 1)) + c, "A").Resize(1, 5) = _
Array(ttl, Trim(szs(s)), Trim(clr(c)), pb, pa)
Next c
Next s
End If
Next i
End With
End Sub
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'm pretty new to VBA and I'm having issues creating a code that looks through a table and if the first 3 row values are the same as the next row, then it will paste the row into a different worksheet.
Currently my table looks like (from column A to column D):
Activity
Role
Country
Hours
A
Senior
US
2
A
Exec
UK
3
A
Exec
UK
1
B
Staff
UK
7
B
Senior
UK
3
C
Manager
UK
5
C
Manager
Uk
4
C
Staff
US
2
My finished table in a different worksheet should should look like:
Activity
Role
Country
Hours
A
Senior
US
2
A
Exec
UK
4
B
Staff
UK
7
B
Senior
UK
3
C
Manager
UK
9
C
Staff
US
2
Currently this is the code I have
Sub FinalOutput()
Dim wip As Worksheet, opt As Worksheet
Dim myRange As Range
Dim eRow As Long
Dim R As Range
Dim i As Long
eRow = 3
i = 3
Set wip = Sheets("WIP_Output")
Set opt = Sheets("Opt")
Set R = Sheets("WIP_Output").Range("A1:C1")
Do
If R.Offset(eRow).Value <> R.Offset(eRow - 1).Value Then
R.Offset(eRow).Copy Destination:=opt.Range("A" & i)
eRow = eRow + 1
i = i + 1
End If
eRow = eRow + 1
Loop
End Sub
Thank you!
Range.Value returns an array if the range contains more than one cell. Your line R.Offset(eRow).Value <> R.Offset(eRow - 1).Value is comparing two arrays, which is not possible with the <> operator, why you get a type mismatch error.
Instead, just compare all three individual values from columns A, B, C without collecting them into an array.
With R.Offset(eRow)
If .Cells(1, 1).Value <> .Cells(0, 1).Value _
Or .Cells(1, 2).Value <> .Cells(0, 2).Value _
Or .Cells(1, 3).Value <> .Cells(0, 3).Value _
Then
'Do Stuff
End If
End With
But from what you said in your post, the boolean is opposite from what you're actually attempting to do. You want to copy the rows from when all three values MATCH, not when they're different. So you want
With R.Offset(eRow)
If .Cells(1, 1).Value = .Cells(0, 1).Value _
And .Cells(1, 2).Value = .Cells(0, 2).Value _
And .Cells(1, 3).Value = .Cells(0, 3).Value _
Then
'Do Stuff
End If
End With
Edit: I should also mention, your loop has no ending condition and will run until it errors at the end of the sheet.
I would look at using a dictionary possibly? I think i can see what you want, fingers crossed. You will need to add the microsoft scripting runtime reference for the dictionary.
This is what i have done so far, got to leave now, so the pasting bit will need the key separation, but this code takes table 1 from a2:d9 and pastes the results in G and H
Sub test()
Dim r As Excel.Range
Dim l As Long
Dim dic As New Scripting.Dictionary
Dim strKey As String
Set r = Range("a2:d9")
a = r.Value
For l = 1 To UBound(a)
strKey = a(l, 1) & "_" & a(l, 2) & "_" & a(l, 3)
If Not dic.Exists(strKey) Then
dic.Add strKey, a(l, 4)
Else
dic.Item(strKey) = dic.Item(strKey) + a(l, 4)
End If
Next l
Range("g1").Resize(dic.Count, 1).Value = Application.Transpose(dic.Keys())
Range("h1").Resize(dic.Count, 1).Value = Application.Transpose(dic.Items())
End Sub
I have downloaded the USA Gross Domestic Product, but this is originally by trimester and I need it my month, thus, I want to divide each cell of GDP / 3 to make my time series longer and be able to plot it by month: I want to create a loop in VBA to divide each value of GDP list 3 times, and then put it below each new value calculated:
Sub PIB()
Set lista = Range("D13:D275")
For Each cell In lista
For i = 1 To 3
Range("E13").Offset(i - 1, 0).Value = cell.Value / 3
Next i
Next cell
End Sub
Nonetheless, when I run it, it divides properly but just over the 3 first cells:
I want to effectively divide each cell 3 times and put it each value below each other, how I can do it?
Is this what you are trying:
Sub PIB()
Dim arr As Variant: arr = Range("D13:D275").Value
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
Dim x As Long
For x = LBound(arr) To UBound(arr)
For i = 1 To 3
dict.Add Join(Array(arr(x, 1), x, i), "|"), arr(x, 1) / 3
Next i
Next
Range("E13").Resize(dict.Count).Value = Application.Transpose(dict.Items)
End Sub
Be aware of the non-explicit Range references.
If you need to split each value on three rows, please use the next code:
Sub SplitOnThreeMonths()
Dim sh As Worksheet, arr As Variant, arrFin As Variant, lastR As Long
Dim i As Long, j As Long, k As Long
Set sh = ActiveSheet
lastR = sh.Range("D" & Rows.count).End(xlUp).row
arr = sh.Range("D13:D" & lastR).Value
ReDim arrFin(1 To UBound(arr) * 3, 1 To 1)
k = 1
For i = 1 To UBound(arr)
For j = 1 To 3
arrFin(k, 1) = arr(i, 1) / 3: k = k + 1
Next j
Next i
sh.Range("E13").Resize(UBound(arrFin, 1), UBound(arrFin, 2)).Value = arrFin
End Sub
It will also allow the same Gross Domestic Product, even if happening that is not very probable. But, who knows?
I'm assuming you need to insert 2 rows to make space for the divided value three times -
however if you don't need to preserve data positions in the adjacent columns, the other answers provided using arrays are better than this one:
Sub PIB()
For i = 275 To 13 Step -1
Rows(i + 1 & ":" & i + 2).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range(Cells(i, "E"), Cells(i + 2, "E")).Value2 = Cells(i, "D").Value2
Next i
End Sub
Please note I haven't qualified your ranges because I don't know what you want them to be, guessing it's the current sheet you're on.
I'm a Macro novice - just figured out how to add the developer tab, so sorry if my question is dumb. I have a list of items in Column A and quantity in Column B. I want to copy Columns A and B to Columns D and E, but only if the value in Column B > 0 - and I want them to stack, no blank spaces for the quantity = 0 ones. I found some code online:
Sub copyAboveZero()
Dim sourceRng As Range
Dim cell As Range
Dim i As Long
Set sourceRng = ActiveSheet.Range("B6:B24")
i = 6
For Each cell In sourceRng
If cell.Value > 0 Then
cell.Resize(1, 2).Copy Destination:=Range("D" & i)
i = i + 1
End If
Next cell
End Sub
The problem is that in this example, the quantity was in the first cell. This one is copying Columns B and C, and I want it to copy A and B. What do I need to change? Also, can you paste special values only? I don't want the formatting to come with it.
How about:
Sub KopyKat()
Dim N As Long, i As Long
Dim j As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
j = 1
For i = 1 To N
If Cells(i, "B").Value > 0 Then
Range(Cells(i, "A"), Cells(i, "B")).Copy Cells(j, "D")
j = j + 1
End If
Next i
End Sub
EDIT#1:
This addresses your comments:
Sub KopyKat()
Dim N As Long, i As Long
Dim J As Long
N = Cells(Rows.Count, "A").End(xlUp).Row
J = 6
For i = 6 To N
If Cells(i, "B").Value > 0 And Cells(i, "B") <> "" Then
Range(Cells(i, "A"), Cells(i, "B")).Copy
Cells(J, "D").PasteSpecial (xlValues)
J = J + 1
End If
Next i
End Sub
I have data that I need to split into individual points. My macro charts the data, as a scatter plot, with: Column A as the title of the chart, Column B as the X axis, and Columns C and D as the Y axis. What I need is for when the Product ID has more than 1 number listed to split the numbers out into their own rows and keep the columns B, C, and D the same for each row created form the original. So for row 167, I would want 3 rows (001,002,003) each with packaging, 200, and 100, in B, C, and D respectively. I am not sure where to begin. I tried to build a macro but, I immediately got tripped up when I tried to record a "Find" Formula to run on the data. Any help would be greatly appreciated.
Column A: 001, 002, 003 // Column B:packaging // Column C:200 // Column D:100
Sorry I couldn't post a screenshot of my data, the forum won't let me. If you have any questions please let me know, I will be sure to check in frequently.
Thanks in advance.
I worte this VERY quickly and without much care for efficiency, but this should do the trick:
Sub SplitUpVals()
Dim i As Long
Dim ValsToCopy As Range
Dim MaxRows As Long
Dim ValToSplit() As String
Dim CurrentVal As Variant
MaxRows = Range("A1").End(xlDown).Row
For i = 1 To 10000000
ValToSplit = Split(Cells(i, 1).Value, ",")
Set ValsToCopy = Range("B" & i & ":D" & i)
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(i, 1).Value = CurrentVal
Range("B" & i & ":D" & i).Value = ValsToCopy.Value
Cells(i + 1, 1).EntireRow.Insert
i = i + 1
MaxRows = MaxRows + 1
Next
Cells(i, 1).EntireRow.Delete
If i > MaxRows Then Exit For
Next i
End Sub
As a note, make sure there's no data in cells beneath your data as it might get deleted.
You will need to parse the data in column A. I would do this by splitting the string in to an array, and then iterate over the array items to add/insert additional rows where necessary.
Without seeing your worksheet, I would probably start with something like this, which will split your cell value from column A in to an array, and then you can iterate over the items in the array to manipulate the worksheet as needed.
Sub TestSplit()
Dim myString as String
Dim myArray() as String
Dim cell as Range
Dim i as Long
For each cell in Range("A2",Range("A2").End(xlDown))
myString = cell.Value
myArray = Split(myString, ",") '<-- converts the comma-delimited string in to an array
For i = lBound(myArray) to uBound(myArray)
If i >= 1 Then
'Add code to manipulate your worksheet, here
End If
Next
Next
End Sub
This is a better solution (now that I had more time :) ) - Hope this does the trick!
Sub SplitUpVals()
Dim AllVals As Variant
Dim ArrayIndex As Integer
Dim RowLooper As Integer
AllVals = Range("A1").CurrentRegion
Range("A1").CurrentRegion.Clear
RowLooper = 1
For ArrayIndex = 1 To UBound(AllVals, 1)
ValToSplit = Split(AllVals(ArrayIndex, 1), ",")
For Each CurrentVal In ValToSplit
CurrentVal = Trim(CurrentVal)
Cells(RowLooper, 1).Value = CurrentVal
Cells(RowLooper, 2).Value = AllVals(ArrayIndex, 2)
Cells(RowLooper, 3).Value = AllVals(ArrayIndex, 3)
Cells(RowLooper, 4).Value = AllVals(ArrayIndex, 4)
RowLooper = RowLooper + 1
Next
Next ArrayIndex
End Sub
Sub DivideData()
'This splits any codes combined into the same line, into their own separate lines with their own separate data
Dim a, b, txt As String, e, s, x As Long, n As Long, i As Long, ii As Long
With Range("a1").CurrentRegion
a = .Value
txt = Join$(Application.Transpose(.Columns(1).Value))
x = Len(txt) - Len(Replace(txt, ",", "")) + .Rows.Count
ReDim b(1 To x * 2, 1 To UBound(a, 2))
For i = 1 To UBound(a, 1)
For Each e In Split(a(i, 1), ",")
If e <> "" Then
For Each s In Split(e, "-")
n = n + 1
For ii = 1 To UBound(a, 2)
b(n, ii) = a(i, ii)
Next
b(n, 1) = s
Next
End If
Next
Next
With .Resize(n)
.Columns(1).NumberFormat = "#"
.Value = b
End With
End With
End Sub