loop to fill different cells regarding an Data base

[Nec11]

Hello to every one,

It seams that I need an loop vba to (from my attachment the red side) split in different boxes the content of one series.
it has to work like this:

-on the yellow sithe on the column "A" I write the series number who exist in Data base
-the yellow side comes filled automaticaly by an vba code.
-the specific series content is made all the time from different parts name from '40 to '10.
-this parts I have to split them in boxes.
-the number of total boxes is all the time different an depending by the total number of parts from the series ( calculated in column "L")


IF anybody can have an look to this problem it would be very helpful for me.

Best Regards.

P.S. if you need some more info please feel free to ask.

[p45cal]

On a sheet called Output(2) in the attached is a button which calls the following macro. See if it does more or less what you want.[VBA]Sub blah()
Dim Source As Range
Range("K2:BI22").Clear
BoxNo = 1
For Each cll In Range("A3", Range("A3").End(xlDown)).Cells
'Application.Goto cll
Set Source = Sheets("data base").Columns(1).Find(what:=cll.Value, lookat:=xlWhole, LookIn:=xlValues)
If Not Source Is Nothing Then
myItems = ""
'Application.Goto Source
For Each SourceCll In Source.Offset(, 2).Resize(, 15)
For i = 1 To SourceCll.Value
myItems = myItems & "¬" & Sheets("data base").Cells(2, SourceCll.Column).Value
Next i
Next SourceCll
myItemsArray = Split(Mid(myItems, 2), "¬")
Set DestCll = cll.Offset(, 10)
DestCll.Value = cll.Value
DestCll.Offset(, 1) = Application.WorksheetFunction.Ceiling(UBound(myItemsArray) / 3, 1)
myOffset = 1
For Each Item In myItemsArray
myOffset = myOffset + 1
If (myOffset - 2) Mod 4 = 0 Then
With DestCll.Offset(, myOffset)
.Value = BoxNo
BoxNo = BoxNo + 1
.Font.ColorIndex = 3
End With
myOffset = myOffset + 1
End If
With DestCll.Offset(, myOffset)
' .Select
.NumberFormat = "@"
.Interior.ColorIndex = 15
.Value = Item
End With
Next Item
End If
Next cll
End Sub[/VBA]

[Nec11]

hello,
Fist of all, Thank you for your effort to help me.

I have tested you code and it seams to be almost ok.

Problems:
- let's look to the series "212017" it has 10 pieces /3 =3.3 that means it will be neccesary to split them in 4 boxes, but I have the possibility in this case to split the series in 3 boxes and the last one made from 4 pieces.
- If we look to the column "B", series from the column "A" are inserted in different moments in during the day. So I need to watch the column "A:A" and to fill the distribution in boxes from the red zone.

Thank you an looking forward for your support.

[p45cal]

but I have the possibility in this case to split the series in 3 boxes and the last one made from 4 pieces.

How on earth does the code know this? Why aren't there 4 pieces in every box? What makes this case different, and how do we know it's different?

[Nec11]

I think it has to be not so difficult, because if we can find an possibility to tell to the code that: if the series has an odd number of pieces in the last box add one more.
in case of the series "212017" with 10 pieces it will look so:
box :x-> 3 pieces; box:y-> 3 pieces; box z-> 4 pieces

Now is am little bit more clear for you?

P.S. if you wont I can send you by PM the complete excel program.
Thank you.

[p45cal]

On a sheet called Output(2) in the attached is a button which calls the following macro. It is quite different, and I'll see if I can streamline it a bit. See if it does more or less what you want.[vba]Sub blah()
Dim Source As Range
Range("K2:BI22").Clear
BoxNo = 1
For Each cll In Range("A3", Range("A3").End(xlDown)).Cells
'Application.Goto cll
Set Source = Sheets("data base").Columns(1).Find(what:=cll.Value, lookat:=xlWhole, LookIn:=xlValues)
If Not Source Is Nothing Then
myItems = ""
'Application.Goto Source
For Each SourceCll In Source.Offset(, 2).Resize(, 15)
For i = 1 To SourceCll.Value
myItems = myItems & "¬" & Sheets("data base").Cells(2, SourceCll.Column).Value
Next i
Next SourceCll
myitemsarray = Split(Mid(myItems, 2), "¬")

Set DestCll = cll.Offset(, 10)
DestCll.Value = cll.Value
BoxesReqd = Application.WorksheetFunction.Ceiling((UBound(myitemsarray) + 1) / 3, 1)
LastBoxSqueeze = False
If (UBound(myitemsarray) + 1) Mod 3 = 1 Then
BoxesReqd = BoxesReqd - 1
LastBoxSqueeze = True
End If
DestCll.Offset(, 1) = BoxesReqd
myOffset = 1
ThisRowsBoxNo = 0
i = 0
Do Until i > UBound(myitemsarray)
myOffset = myOffset + 1
xx = (myOffset - 2) Mod 5 'Then
Select Case xx
Case 0
With DestCll.Offset(, myOffset)
.Value = BoxNo
BoxNo = BoxNo + 1
ThisRowsBoxNo = ThisRowsBoxNo + 1
.Font.ColorIndex = 3
End With
Case 1 To 3
With DestCll.Offset(, myOffset)
' .Select
.NumberFormat = "@"
.Interior.ColorIndex = 15
.Value = myitemsarray(i)
i = i + 1
End With
Case 4
If LastBoxSqueeze And (ThisRowsBoxNo = BoxesReqd) Then
With DestCll.Offset(, myOffset)
' .Select
.NumberFormat = "@"
.Interior.ColorIndex = 15
.Value = myitemsarray(i)
i = i + 1
End With
End If
End Select
Loop
End If
Next cll
End Sub[/vba]

[Nec11]

Hello,
I have tested the new code.
Is working like charm.

I had to change somet thinghs over there to make him to writh for one line in the moment, but now I have the problem that code do not know to count continously the boxes numbers and it start all the time from 1

It is possible to:
-Teach the code to count continously
-to create an sheet named:"Settings" and to tell to the code for the aricle "x" we use 2 pieces/box and for article "y" we use 3 pieces/box.

To be ease to see the changes in VBA code I reattach the file.

Best Regards. & Thank you

[p45cal]

This will take up too much of my time, sorry.

[Nec11]

Is not a big hurry for that. When you have time it wold be great your help.