Distributing cell value (not text-to-columns)

[gregbowey]

Hi

I have a spreadsheet of weight values that I want to distribute evenl
into 500g lots. Let's say I'm importing marbles and I have a whole bunc
of varieties that need to be kept separate from each other. See belo
for the raw data.

DATE Country Origin Marble Lot Weight (kg)
01/04/2013 AUS 2 MAR001 2.6
01/04/2013 AUS 3 MAR001 1.9
01/04/2013 AUS 3 MAR002 0.7
01/04/2013 AUS 3 MAR003 3.7
01/04/2013 AUS 3 MAR004 2.02
01/04/2013 AUS 4 MAR004 0.24

What I would like to do is have a formulated spreadsheet that picks u
this data and separates it into 500g lots and assigns a sequentia
letter of the alphabet to it and also puts out the remainder (the lef
overs in a smaller bag that is <500). This last part is less essentia
than the overall function of the distribution to the correct number o
500g segments. The ideal output will look like this:

DATE Country Origin Marble Lot Weight (kg)
01/04/2013 AUS 2 MAR001 A 0.5
01/04/2013 AUS 2 MAR001 B 0.5
01/04/2013 AUS 2 MAR001 C 0.5
01/04/2013 AUS 2 MAR001 D 0.5
01/04/2013 AUS 2 MAR001 E 0.5
01/04/2013 AUS 2 MAR001 F 0.1
01/04/2013 AUS 3 MAR001 A 0.5
01/04/2013 AUS 3 MAR001 B 0.5
01/04/2013 AUS 3 MAR001 C 0.5
01/04/2013 AUS 3 MAR001 D 0.4
01/04/2013 AUS 3 MAR002 A 0.5
01/04/2013 AUS 3 MAR002 B 0.2
01/04/2013 AUS 3 MAR003 A 0.5
01/04/2013 AUS 3 MAR003 B 0.5
01/04/2013 AUS 3 MAR003 C 0.5
01/04/2013 AUS 3 MAR003 D 0.5
01/04/2013 AUS 3 MAR003 E 0.5
01/04/2013 AUS 3 MAR003 F 0.5
01/04/2013 AUS 3 MAR003 G 0.5
01/04/2013 AUS 3 MAR003 H 0.2
01/04/2013 AUS 3 MAR004 A 0.5
01/04/2013 AUS 3 MAR004 B 0.5
01/04/2013 AUS 3 MAR004 C 0.5
01/04/2013 AUS 3 MAR004 D 0.5
01/04/2013 AUS 3 MAR004 E 0.02
01/04/2013 AUS 4 MAR004 A 0.24

Apologies for the large dataset but I need these different combination
to work. Is there anyone out there that knows of a way to do this

 

[Ron Rosenfeld]

Hi

I have a spreadsheet of weight values that I want to distribute evenly
into 500g lots. Let's say I'm importing marbles and I have a whole bunch
of varieties that need to be kept separate from each other. See below
for the raw data.

DATE Country Origin Marble Lot Weight (kg)
01/04/2013 AUS 2 MAR001 2.6
01/04/2013 AUS 3 MAR001 1.9
01/04/2013 AUS 3 MAR002 0.7
01/04/2013 AUS 3 MAR003 3.7
01/04/2013 AUS 3 MAR004 2.02
01/04/2013 AUS 4 MAR004 0.24

What I would like to do is have a formulated spreadsheet that picks up
this data and separates it into 500g lots and assigns a sequential
letter of the alphabet to it and also puts out the remainder (the left
overs in a smaller bag that is <500). This last part is less essential
than the overall function of the distribution to the correct number of
500g segments. The ideal output will look like this:

DATE Country Origin Marble Lot Weight (kg)
01/04/2013 AUS 2 MAR001 A 0.5
01/04/2013 AUS 2 MAR001 B 0.5
01/04/2013 AUS 2 MAR001 C 0.5
01/04/2013 AUS 2 MAR001 D 0.5
01/04/2013 AUS 2 MAR001 E 0.5
01/04/2013 AUS 2 MAR001 F 0.1
01/04/2013 AUS 3 MAR001 A 0.5
01/04/2013 AUS 3 MAR001 B 0.5
01/04/2013 AUS 3 MAR001 C 0.5
01/04/2013 AUS 3 MAR001 D 0.4
01/04/2013 AUS 3 MAR002 A 0.5
01/04/2013 AUS 3 MAR002 B 0.2
01/04/2013 AUS 3 MAR003 A 0.5
01/04/2013 AUS 3 MAR003 B 0.5
01/04/2013 AUS 3 MAR003 C 0.5
01/04/2013 AUS 3 MAR003 D 0.5
01/04/2013 AUS 3 MAR003 E 0.5
01/04/2013 AUS 3 MAR003 F 0.5
01/04/2013 AUS 3 MAR003 G 0.5
01/04/2013 AUS 3 MAR003 H 0.2
01/04/2013 AUS 3 MAR004 A 0.5
01/04/2013 AUS 3 MAR004 B 0.5
01/04/2013 AUS 3 MAR004 C 0.5
01/04/2013 AUS 3 MAR004 D 0.5
01/04/2013 AUS 3 MAR004 E 0.02
01/04/2013 AUS 4 MAR004 A 0.24

Apologies for the large dataset but I need these different combinations
to work. Is there anyone out there that knows of a way to do this?

Don't apologize for the data set. Usually most posters don't provide enough.
Your data set and results look as if each line in the raw data will be split separately; in other words, we won't have to combine two or more sets of the same type of Marble.

That being the case, this can be done with a VBA Macro.

To enter this Macro (Sub), <alt-F11> opens the Visual Basic Editor.
Ensure your project is highlighted in the Project Explorer window.
Then, from the top menu, select Insert/Module and
paste the code below into the window that opens.

To use this Macro (Sub), <alt-F8> opens the macro dialog box. Select the macro by name, and <RUN>.

=============================================
Option Explicit
Sub Marbles()
Dim rDest As Range
Dim v As Variant, vRes As Variant
Dim s As String
Dim i As Long, j As Long, k As Long, L As Long, M As Long
Dim lResRowCount As Long
Dim d As Double
Dim sLot As String
Const dLotSize As Double = 0.5

'The following constants (column numbers) could be
' determined by this macro if they might vary
Const colCount As Long = 6
Const colOrigin As Long = 3
Const colMarble As Long = 4
Const colWeight As Long = 6

'put results "next to" original data
'could easily put on a new worksheet or elsewhere
' or even replace the original if not needed
Set rDest = Range("a1").Offset(columnoffset:=colCount + 1)

'read original data into an array for faster processing
v = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=colCount)

'determine dimension of results array
For i = 1 To UBound(v)
d = v(i, colWeight)
j = Int(d / dLotSize)
If (j * dLotSize) < d Then j = j + 1
lResRowCount = lResRowCount + j
Next i

'populate Results Array
k = 1
ReDim vRes(1 To lResRowCount, 1 To colCount)
For i = 1 To UBound(v, 1)
sLot = Chr(64) 'Code for "A" -1
M = k
For j = 1 To colCount
d = v(i, colWeight)
L = Int(d / dLotSize)
If (L * dLotSize) < d Then L = L + 1
For k = M To M + L - 1
Select Case j
Case 1 To 4
vRes(k, j) = v(i, j)
Case 5
sLot = Chr(Asc(sLot) + 1)
vRes(k, j) = sLot
Case 6
If d > dLotSize Then
vRes(k, j) = dLotSize
Else
vRes(k, j) = d
End If
d = d - dLotSize
End Select
Next k
Next j
Next i

'copy Labels
Range("A1").Resize(columnsize:=colCount).Copy Destination:=rDest


Set rDest = rDest.Resize(rowsize:=UBound(vRes, 1), columnsize:=UBound(vRes, 2)).Offset(rowoffset:=1)
Range(rDest, Cells(Rows.Count, rDest.Column)).Clear

rDest = vRes

End Sub
=====================================================

 

[gregbowey]

Excellent, Ron! Thanks so much for your help. This has done exactly wha
I asked.

Just one thing I am wondering though, once I've used up all of th
letters of the alphabet (let's assume that I have one marble lot tha
is, say, 50kg) it starts going through symbols and lower case letters
Is there a way to get the spreadsheet to go ....X|Y|Z|AA|AB|AC...
rather than going through symbols and lower case letters?

Thanks again. You've just saved me days of work across a whole year

 

[Ron Rosenfeld]

Excellent, Ron! Thanks so much for your help. This has done exactly what
I asked.

Just one thing I am wondering though, once I've used up all of the
letters of the alphabet (let's assume that I have one marble lot that
is, say, 50kg) it starts going through symbols and lower case letters.
Is there a way to get the spreadsheet to go ....X|Y|Z|AA|AB|AC....
rather than going through symbols and lower case letters?

Thanks again. You've just saved me days of work across a whole year!

Glad to help. Thanks for the feedback.

One way of doing sequential all caps lettering would be to use the column labelling method existing in Excel. This limits you to 16,384 lots. If that will be an issue, we'll need to use another scheme, but this one is easy to implement:

==================================
Option Explicit
Sub Marbles()
Dim rDest As Range
Dim v As Variant, vRes As Variant
Dim s As String
Dim i As Long, j As Long, k As Long, L As Long, M As Long
Dim lResRowCount As Long
Dim d As Double
Dim sLot As String, lLot As Long
Const dLotSize As Double = 0.5

'The following constants (column numbers) could be
' determined by this macro if they might vary
Const colCount As Long = 6
Const colOrigin As Long = 3
Const colMarble As Long = 4
Const colWeight As Long = 6

'put results "next to" original data
'could easily put on a new worksheet or elsewhere
' or even replace the original if not needed
Set rDest = Range("a1").Offset(columnoffset:=colCount + 1)

'read original data into an array for faster processing
v = Range("A2", Cells(Rows.Count, "A").End(xlUp)).Resize(columnsize:=colCount)

'determine dimension of results array
For i = 1 To UBound(v)
d = v(i, colWeight)
j = Int(d / dLotSize)
If (j * dLotSize) < d Then j = j + 1
lResRowCount = lResRowCount + j
Next i

'populate Results Array
k = 1
ReDim vRes(1 To lResRowCount, 1 To colCount)
For i = 1 To UBound(v, 1)
lLot = 0 'column number = "A" -1
M = k
For j = 1 To colCount
d = v(i, colWeight)
L = Int(d / dLotSize)
If (L * dLotSize) < d Then L = L + 1
For k = M To M + L - 1
Select Case j
Case 1 To 4
vRes(k, j) = v(i, j)
Case 5
lLot = lLot + 1
sLot = Cells(1, lLot).Address(columnabsolute:=False)
sLot = Left(sLot, InStr(sLot, "$") - 1)
vRes(k, j) = sLot
Case 6
If d > dLotSize Then
vRes(k, j) = dLotSize
Else
vRes(k, j) = d
End If
d = d - dLotSize
End Select
Next k
Next j
Next i

'copy Labels
Range("A1").Resize(columnsize:=colCount).Copy Destination:=rDest


Set rDest = rDest.Resize(rowsize:=UBound(vRes, 1), columnsize:=UBound(vRes, 2)).Offset(rowoffset:=1)
Range(rDest, Cells(Rows.Count, rDest.Column)).Clear

rDest = vRes

End Sub
========================================

 

[gregbowey]

Thank you so much for your work here. It is very much appreciated!
have one last tweak that I would like to know if it's possible. In th
original query, I asked that a remainder be shown i.e. 0.5, 0.5, 0.5
0.23. Is it possible to get the macro to spit the last one out as a 0.
as well (rather than the exact remainder)

 

[Ron Rosenfeld]

Thank you so much for your work here. It is very much appreciated! I
have one last tweak that I would like to know if it's possible. In the
original query, I asked that a remainder be shown i.e. 0.5, 0.5, 0.5,
0.23. Is it possible to get the macro to spit the last one out as a 0.5
as well (rather than the exact remainder)?

I suspect the algorithm would have been much simpler had that requirement been made known at the beginning, but the present algorithm will work with just a minor change:

====================
....
Case 6
If d > dLotSize Then
vRes(k, j) = dLotSize
Else
vRes(k, j) = dLotSize
End If
d = d - dLotSize
....
=====================================

 

[gregbowey]

I needed both outcomes as it turns out. The original is certainly mor
useful but I have a place for this last adjustment too.

This is the final adjustment needed. You've done an extremely good an
helpful job for me.

Again, thanks so much for your efforts

 

[Ron Rosenfeld]

I needed both outcomes as it turns out. The original is certainly more
useful but I have a place for this last adjustment too.

This is the final adjustment needed. You've done an extremely good and
helpful job for me.

Again, thanks so much for your efforts!

Glad to help. And glad that they both are working for you as desired.
Thanks for the feedback.