VBA extracting data

[Grange2]

Hi Everyone,

I'm looking to to use a VBA Macro to extract data in a particular fashion. The data sheet looks like below:

Book1
	A	B	C	D	E	F	G
1	Code	Description		QTY	Price	GST	Total
2	*			Section	1
3	16875	Paper	324234	1	2	3	4
4	16876	Paper	324234	1	2	3	4
5	16877	Paper	324234	1	2	3	4
6	16878	Paper	324234	1	2	3	4
7	16879	Paper	324234	1	2	3	4
8	16880	Paper	324234	1	2	3	4
9	*		Section	2
10	16876	Paper	42384	5	4	8	1
11	57532	Rock	1230	7	1	6	8
12	56621	Rock	1235	8	2	5	9
13	*		Section	3
14	5412	Scissors	5121	5	6	4	5
15	2132	Scissors	212	12	2	5	21
16	54	Scissors	548	58	3	3	1
17
Sheet1

Each section has a different number of items listed ( possibly more than 3 sections per data sheet as well)and if the data could be extracted to resemble below:

Book1
	A	B	C	D	E	F	G	H	I	J
1	Section	Code					QTY	Price	GST	Total
2	Section 1	16875					1	2	3	4
3	Section 1	16876					1	2	3	4
4	Section 1	16877					1	2	3	4
5	Section 1	16878					1	2	3	4
6	Section 1	16879					1	2	3	4
7	Section 1	16880					1	2	3	4
Sheet2

Any help would be greatly appreciated

Thank you.

 

[Zot]

Try this

Sub Sectionize()

Dim nSection As Long, nRow As Long
Dim Section As Boolean
Dim cell As Range, rngData As Range
Dim ws1 As Worksheet, w2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")

Set rngData = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp))

nSection = 0
nRow = 1
For Each cell In rngData
    If cell = "*" Then
        nSection = nSection + 1
        Section = True
        Cont = False
        GoTo nxLine
    End If
    If Section Then
        nRow = nRow + 1
        With ws2
            .Range("A" & nRow) = "Section " & nSection
            .Range("B" & nRow) = ws1.Range("A" & cell.Row)
            ws1.Range("D" & cell.Row, "G" & cell.Row).Copy .Range("G" & nRow)
        End With
    End If
nxLine:
Next
ws2.Activate

End Sub

 

[Grange2]

Wow that works splendidly! To add on to the previous issue if the sections were different names is it possible to capture that as well? E.G

Book1
	A	B	C	D	E	F	G
1	Code	Description		QTY	Price	GST	Total
2	*			Food	Delight
3	16875	Paper	324234	1	2	3	4
4	16876	Paper	324234	1	2	3	4
5	16877	Paper	324234	1	2	3	4
6	16878	Paper	324234	1	2	3	4
7	16879	Paper	324234	1	2	3	4
8	16880	Paper	324234	1	2	3	4
9	*		Office	Suppliers
10	16876	Paper	42384	5	4	8	1
11	57532	Rock	1230	7	1	6	8
12	56621	Rock	1235	8	2	5	9
13	*		Post	Office	International
14	5412	Scissors	5121	5	6	4	5
15	2132	Scissors	212	12	2	5	21
16	54	Scissors	548	58	3	3	1
Sheet1

I really appreciate your time and effort on this!

Thank you so much!

 

[Zot]

You meant Food, Suppliers and Office is section name?. Then I need o modify code since I have no idea in your previous example since the word section is in two different columns.

Now I think the section name would be
Food Delight
Office Suppliers
Post Office International

If this is true then it is different ball game. You should have provided real example and explain better from the very beginning. This would save time

 

[Zot]

Okay. Try this

Sub Sectionize()

Dim nRow As Long
Dim SectionName As String
Dim Section As Boolean
Dim cell As Range, rngData As Range
Dim ws1 As Worksheet, w2 As Worksheet

Application.ScreenUpdating = False

Set ws1 = ActiveWorkbook.Sheets("Sheet1")
Set ws2 = ActiveWorkbook.Sheets("Sheet2")

Set rngData = ws1.Range("A1", ws1.Cells(Rows.Count, "A").End(xlUp))

nRow = 1
For Each cell In rngData
    If cell = "*" Then
        With ws1
            SectionName = Trim(.Range("B" & cell.Row) & .Range("C" & cell.Row) & _
                                    .Range("D" & cell.Row) & .Range("E" & cell.Row))
            Section = True
            GoTo nxLine
        End With
    End If
    If Section Then
        nRow = nRow + 1
        With ws2
            .Range("A" & nRow) = SectionName
            .Range("B" & nRow) = ws1.Range("A" & cell.Row)
            ws1.Range("D" & cell.Row, "G" & cell.Row).Copy .Range("G" & nRow)
        End With
    End If
nxLine:
Next
ws2.Activate

End Sub

 

[Grange2]

Amazing! Thank you so much!!!!

 

[Zot]

Amazing! Thank you so much!!!!

Thanks for update