Slicing A Dynamic Array

[Beryo]

Dear all,<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Inputs <o></o>
1) A single row array – specified by the maximum value (below=10) and generated by randomizing the integers between 1 to maximum value.<o></o>
2) Number of zeroes to be inserted <o></o>
e.g. After inserting the zeroes randomly I get the following array <o></o>
A= [1 8 4 0 6 9 2 7 0 3 5 10]<o></o>
I would like to dissect A into smaller single row matrices based on the zeroes in the locations <o></o>
In the example above number of zeroes =2 Hence the matrix needs to be dissected into 3 as follows <o></o>
B1= [1 8 4]<o></o>
B2= [6 9 2 7]<o></o>
B3= [3 5 4]<o></o>
How can I generate B1, B2, etc based on the number of zeroes?<o></o>
Once B1,B2,..are created, how can I generate a new matrix C (4X3 matrix in this case) from them?<o></o>
1 8 4 0 <o></o>
6 9 2 7<o></o>
3 5 4 0<o></o>
Note that C (1, 4) = C(3,4)=0 as the column size of C is limited by B2 (that has 4 elements)<o></o>
As mentioned the only inputs are the max value and the number of zeroes<o></o>
Thank you in advance.<o></o>
B.<o></o>

 

[venkat1926]

sheet1 contains data in row no. 1 like this

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L
1	1	8	4	0	6	9	2	7	0	3	5	10
Sheet1

then park all the three macros in the mdoule. but run ONLY MACRO TEST.

Sub test()
Dim r As Range, r0 As Range, dest As Range, cfind As Range, add As String
With Worksheets("sheet1")
Set r = .Range("A1")
Set r0 = .Rows("1:1").Cells.Find(what:=0, lookat:=xlWhole, after:=r)
'MsgBox r0.Address
add = r0.Address
Range(r, r0.Offset(0, -1)).Copy
Worksheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
Do
Set r = r0.Offset(0, 1)
Set r0 = .Rows("1:1").Cells.FindNext(r0)
If r0 Is Nothing Then Exit Do
If r0.Address = add Then Exit Do
Range(r, r0.Offset(0, -1)).Copy
Worksheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
Set r = r0.Offset(0, 1)
Loop
Range(r, r.End(xlToRight)).Copy
Worksheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial
End With
 Worksheets("sheet2").Range("A1").EntireRow.Delete
 testone
End Sub

Sub testone()
Dim j As Long
With Worksheets("sheet2")
For j = 1 To Range("A1").End(xlDown).Row
If WorksheetFunction.CountA(Range(.Cells(j, 1), .Cells(j, 1).End(xlToRight))) <= 3 Then
.Cells(j, 1).End(xlToRight).Offset(0, 1) = 0
End If
Next j
End With
End Sub

Sub undo()
Worksheets("sheet2").Cells.Clear
End Sub