I’m looking for a function or Macro to help find a solution between an order sheet and a sheet dedicated to printing labels for the items ordered.
The order sheet has 3 columns of info: qtyordered, packaging and item. When someone orders more than 1 case of something, I need a label tag for each item.
I’m looking for a way to split the value in qtyordered column into individual rows that will repeat as many times (i.e.
| | | |
-|-|-
3.5|box|apples
becomes:
||||
-|-|-
1 | box | apples,
1 | box | apples,
1 | box | apples,
0.5 | box | apples,
All in consecutive rows.
I haven’t been able to get an idea of how to pull this off in excel with either functions or macros. I’m know I could use office scripts and handle it like I would in JavaScript; however, I don’t think this company has an up to date version of excel, so I have to go old school.
Any ideas on how to solve this riddle would be greatly appreciated
Thanks in advance!
Jimmy
Does this do what you want?
Contents of the "order" sheet, (range A1:C6):
qtyordered
packaging
item
3,5
box
apples
5
sack
plums
0
error
error
1
none
pinapples
3
wheelbarrow
melons
code:
Sub expandData2()
Dim rng As Range, arr() As Variant, targetCell As Range, splitSize As Double
'targetCell is where the result will start being written
Set targetCell = Worksheets("label").Range("A2")
splitSize = 1
'clear the previous labels, if there are any
With Worksheets("label")
If .Range("C2").Value <> "" Then
.Range("A2:C" & .Range("C" & .Rows.Count).End(xlUp).Row).Clear
End If
End With
'find the last row on the "order" sheet, assign the range with the order to the arr array
With Worksheets("order")
Set rng = .Range("A2:C" & .Range("C" & .Rows.Count).End(xlUp).Row)
End With
arr = rng
Dim quantity As Double, packaging As String, item As String, rowCounter
'loop through all rows of the order
For i = 1 To UBound(arr)
quantity = arr(i, 1)
packaging = arr(i, 2)
item = arr(i, 3)
'while quantity is larger than 0, subtract splitSize from it and create new label row
Do While quantity > 0
quantity = quantity - splitSize
If quantity < 0 Then
targetCell.Offset(rowCounter, 0) = quantity + splitSize
Else
targetCell.Offset(rowCounter, 0) = splitSize
End If
targetCell.Offset(rowCounter, 1) = packaging
targetCell.Offset(rowCounter, 2) = item
rowCounter = rowCounter + 1
Loop
Next i
End Sub
Result on "label" sheet:
qtyordered
packaging
item
1
box
apples
1
box
apples
1
box
apples
0,5
box
apples
1
sack
plums
1
sack
plums
1
sack
plums
1
sack
plums
1
sack
plums
1
none
pinapples
1
wheelbarrow
melons
1
wheelbarrow
melons
1
wheelbarrow
melons
Related
Here is my problem, I have those data on my Sheet1
A B C
1 Name Account Amount
2 John HSBC -20000
3 Ashley JPM 140000
4 Rose BAML 70000
5 John DB 10000
6 Rose Barclays -25000
7 Ashley JPM -3000
My goal is to use vba in order to sort lines and group them by name and amount. The result that I'm looking for in Sheet2 is :
A B C
1 Name Account Amount
2 John HSBC -20000
3 John DB 10000
4
5 Ashley JPM -3000
6 Ashley JPM 140000
7
8 Rose Barclays -25000
9 Rose BAML 70000
I already succeeded in taking the negative values first, but I still have difficulties in taking the rest and leave a blank line between groups.
Here is the code that I started :
Option Explicit
Sub sort_account()
Dim list_amount As Range, amount As Range
Dim b As Integer
Worksheets("Sheet1").Activate
Set list_amount = Worksheets("Sheet1").Range("C2", Range("C2").End(xlDown))
For Each amount In list_amount
If amount.Value < 0 Then
b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
Worksheets("Sheet2").Cells(b + 1, 1).Value = amount.Offset(0, -2)
Worksheets("Sheet2").Cells(b + 1, 2).Value = amount.Offset(0, -1)
Worksheets("Sheet2").Cells(b + 1, 3).Value = amount
End If
Next amount
Worksheets("Sheet2").Activate
End Sub
And this gives me as a result :
A B C
1 Name Account Amount
2 John HSBC -20000
5 Ashley JPM -3000
8 Rose Barclays -25000
I really have difficulties for the rest. Do you have any ideas ? I thank you in advance for that.
Nb : The order doesn't matter, I just want that the first values of each group is the negative amount.
Thanks!
If this were my project, I would do it in three distinct steps: Copy all the data from sheet 1 to sheet 2; Sort the data in the preferred order; Insert the blank rows, starting from the bottom.
The following code should do what you’re after.
Option Explicit
Sub sort_account()
Dim LastRow As Long, i As Long
Sheet2.Cells.ClearContents
Sheet1.UsedRange.Copy Sheet2.Range("A1")
Sheet2.Columns("A:C").Sort Key1:=Sheet2.Range("A2"), order1:=xlAscending, _
Key2:=Sheet2.Range("C2"), order2:=xlAscending, Header:=xlYes
LastRow = Sheet2.Cells(Rows.Count, "A").End(xlUp).Row
For i = LastRow To 4 Step -1
If Sheet2.Cells(i, "A") = Sheet2.Cells(i - 1, 1) Then
Sheet2.Cells(i - 1, "A").EntireRow.Insert
End If
Next i
End Sub
If your version of Excel supports Dynamic Arrays then you can do the following
This solution adds an extra row for each unique name, sorts the new data, and then blanks out the added rows.
E2 is =CHOOSE({1,2,3},UNIQUE(A2:A7),"temp",99999999). This creates an array with all the unique names in the first column, "temp" in the second column and 99999999 in the third (to be used for sorting).
F6 is =ROWS(A2:C7) the count of the rows in the data
F7 is =ROWS(E2#) the count of unique names
A10 is =IF(SEQUENCE(F6+F7)<=F6,A2:C7,INDEX(E2#,SEQUENCE(F6+F7)-F6,SEQUENCE(1,3))). This appends the original data to the new data.
E10 is =SORT(A10#,{1,3}), the appended data sorted.
I10 is =IF(F10:F18="temp","",E10#). This blanks out all the temps rows.
If your version of Excel supports LET you can do this in one cell.
=LET(data,A2:C7,
tempRows,CHOOSE({1,2,3},UNIQUE(A2:A7),"temp",99999999),
totalRows,ROWS(data),
uniqueNames,ROWS(tempRows),
outRows, SEQUENCE(totalRows+uniqueNames),
unsorted,IF(outRows<=totalRows,data,INDEX(tempRows,outRows-totalRows,{1,2,3})),
sorted,SORT(unsorted,{1,3}),
result, IF(INDEX(sorted,outRows,2)="temp","",INDEX(sorted,outRows,{1,2,3})),
result)
Hi this is my first post so please be gentle. I have a large amount of data being exported from Access into Excel. Access reports exported into Excel don't behave nicely otherwise I would use that method. All the calculations are being done in Access due to complexity and size of the data involved. I need to have a user friendly way of drilling down the data hence grouping in Excel would be perfect if I could get it to work.
The data has a hierarchy as per the below:
State
Store
Category
Item
At a top level you would just see the states with all the data so you can compare performance. You would then click the plus in the state you wanted to analyse which would show all the stores in the state, then you would click on a store to show the categories and then click on the category to show the items in the category.
I can add a Group index if required as per the below (I have included the data format also if that helps).
There are a number of states with up to 100 stores in each state 10 categories and then 100 items per category - so a lot of data and hence a macro.
Any help would be greatly appreciated as I am tearing my hair out.
Group Description Data Format
1 State AA
2 Store 1
3 Sub category Text
4 Item 2222
4 Item 2223
3 Sub category Text A
4 Item 2225
4 Item 2226
3 Sub category Text B
4 Item 2228
4 Item 2229
3 Sub category Text C
4 Item 2231
4 Item 2232
2 Store 2
3 Sub category Text
4 Item 2222
4 Item 2223
3 Sub category Text A
4 Item 2225
4 Item 2226
3 Sub category Text B
4 Item 2228
4 Item 2229
3 Sub category Text C
4 Item 2231
4 Item 2232
1 State BB
2 Store 3
3 Sub category Text
4 Item 2222
4 Item 2223
3 Sub category Text A
4 Item 2225
4 Item 2226
3 Sub category Text B
4 Item 2228
4 Item 2229
3 Sub category Text C
4 Item 2231
4 Item 2232
2 Store 4
3 Sub category Text
4 Item 2222
4 Item 2223
3 Sub category Text A
4 Item 2225
4 Item 2226
3 Sub category Text B
4 Item 2228
4 Item 2229
3 Sub category Text C
4 Item 2231
4 Item 2232
From my answer in a different post:
Sub subGroupTest()
Dim sRng As Range, eRng As Range
Dim groupMap() As Variant
Dim subGrp As Long, i As Long, j As Long
Dim startRow As Range, lastRow As Range
Dim startGrp As Range, lastGrp As Range
ReDim groupMap(1 To 2, 1 To 1)
subGrp = 0
i = 0
Set startRow = Range("A1")
' Create a map of the groups with their cell addresses and an index of the lowest subgrouping
Do While (startRow.Offset(i).Value <> "")
groupMap(1, i + 1) = startRow.Offset(i).Address
groupMap(2, i + 1) = UBound(Split(startRow.Offset(i).Value, "."))
If subGrp < groupMap(2, i + 1) Then subGrp = groupMap(2, i + 1)
ReDim Preserve groupMap(1 To 2, 1 To (i + 2))
Set lastRow = Range(groupMap(1, i + 1))
i = i + 1
Loop
' Destroy already existing groups, otherwise we get errors
On Error Resume Next
For k = 1 To 10
Rows(startRow.Row & ":" & lastRow.Row).EntireRow.Ungroup
Next k
On Error GoTo 0
' Create the groups
' We do them by levels in descending order, ie. all groups with an index of 3 are grouped individually before we move to index 2
Do While (subGrp > 0)
For j = LBound(groupMap, 2) To UBound(groupMap, 2)
If groupMap(2, j) >= CStr(subGrp) Then
' If current value in the map matches the current group index
' Update group range references
If startGrp Is Nothing Then
Set startGrp = Range(groupMap(1, j))
End If
Set lastGrp = Range(groupMap(1, j))
Else
' If/when we reach this loop, it means we've reached the end of a subgroup
' Create the group we found in the previous loops
If Not startGrp Is Nothing And Not lastGrp Is Nothing Then Range(startGrp, lastGrp).EntireRow.Group
' Then, reset the group ranges so they're ready for the next group we encounter
If Not startGrp Is Nothing Then Set startGrp = Nothing
If Not lastGrp Is Nothing Then Set lastGrp = Nothing
End If
Next j
' Decrement the index
subGrp = subGrp - 1
Loop
End Sub
I have a listbox with column 4 columns (Name, Marital Status, Years Married, Gender). I need to copy the contents of my listbox to sheet 1. For example, if the listbox contained: Joe, Single, 0, Male then I need to have cells A2:D2 have the values Joe, Single, 0, Male, respectively.
You can loop over the rows/columns in a listbox, example:
For r = 0 to ListBox.ListCount - 1
For c = 0 to ListBox.ListColumns.Count - 1
Range("A2").Offset(r, c).Value = ListBox.List(r,c)
Next
Next
just changed ListColumns.Count - 1 to .ColumnCount - 1
For r = 0 to ListBox.ListCount - 1
For c = 0 to ListBox.ColumnCount - 1
Range("A2").Offset(r, c).Value = ListBox.List(r,c)
Next
Next
I have the following dataset:
Name Code Output Type
Alice Apple -100 B
Alice Apple +60 S
Alice Banana -52 S
Alice Apple +40 S
Alice mango -5000 S
Bob Kiwi -500 B
Bob Kiwi +500 S
Bob peach -40 S
Dan Banana -50 S
Dan peach +28 S
I want to reduce this data using the following criteria:
IF records with a given name do not contain "B" in any record in column "Type" then I don't want to consider it. So the "Dan" records are out. Of the 5 Alice records, the first one has a "Type" "B" and Bob has a "Type" "B" as well.
For others, I want to see which fruit numbers don't net out to zero.
So this is what I would like to see:
Name Code output Type
Alice Banana -52 S
Alice mango -5000 S
Bob peach -40 S
Right now, First I am doing a SumIfs over Name and Code.
=SUMIFS($C$2:$C$21,$B$2:$B$21,B2,$A$2:$A$21,A2)
Then I create a column where I give the value 1 when type = B and 0 otherwise.
=IF(D2="B",1,0)
Then I am doing a Sumif to figure out which names have a "B"
=SUMIF($A$2:$A$21,A2,$F$2:$F$21)
Then I will filter the ones which don't have a B and where the SUMIFS are not zero.
Right now this is in-sheet. I intend to use these formula in a VBA macro. Is there a better way to do this? Say without creating new columns?
Assuming your columns are in the correct order as above. the below code will generate a new 5th column with 0, 1.
Option Explicit
Option Compare Text
Sub SetFilter()
Dim sh As Worksheet: Set sh = Sheet1
' YOU MUST add reference "Microsoft Scripting Runtime" from tools menu to use this object...
Dim FruitSums As New Scripting.Dictionary ' key = name of fruit, value is running total
FruitSums.CompareMode = TextCompare
Dim iR As Integer
Dim lbl As String
Dim value As Variant
'get fruit sums
For iR = 2 To sh.UsedRange.Rows.Count
lbl = sh.Cells(iR, 2)
value = sh.Cells(iR, 3)
If IsNumeric(value) Then
If FruitSums.Exists(lbl) Then
FruitSums(lbl) = FruitSums(lbl) + CLng(value)
Else
FruitSums(lbl) = CLng(value)
End If
End If
Next
' calculate the filter column
For iR = 2 To sh.UsedRange.Rows.Count
If sh.Cells(iR, 4) = "B" Then
sh.Cells(iR, 5) = 1 ' ok, is a B
Else
lbl = sh.Cells(iR, 2)
If FruitSums.Exists(lbl) Then
If CLng(FruitSums(lbl)) = 0 Then
sh.Cells(iR, 5) = 0 ' not ok, is total 0
Else
sh.Cells(iR, 5) = 1 ' ok, is not 0
End If
Else ' this case should not occur
sh.Cells(iR, 5) = -1 ' unexpected output.
End If
End If
Next
End Sub
I have a list of products listed on one worksheet, but not every product will have a value. In a separate worksheet I want it to only pull over the products that have values. I have been able to output the fist column of pizza but pizza-crust will not continue
Sheet 1 called prices
list pizza pizza-crust pizza-thin
pepper 1 5 8
beef 2
bacon 3 6
pineapple 4 9
mushroom 7 10
The macro that I have does the following
list pizza
pepper 1
beef 2
bacon 3
pineapple 4
how can i get it to fill in the data for the rest of the columns so that it would put pizza crust and then the data for each and then put pizza-thin and the data for that
below is the macro
Sub Button2_Click()
Dim column As Integer
column = 1
newrow = 1
Do Until Worksheets("sheet1").Cells(column, 1).Value = ""
If Worksheets("sheet1").Cells(column, 2).Value <> "" Then
Worksheets("sheet2").Cells(newrow, 1).Value = Worksheets("sheet1").Cells(column, 1).Value
Worksheets("sheet2").Cells(newrow, 2).Value = Worksheets("sheet1").Cells(column, 2).Value
newrow = newrow + 1
End If
column = column + 1
Loop
End Sub
thanks
Select cell B2 and run my unpivot add-in (available here). It should be easy after that to add the additional zero columns.