Organize data

[Zibi]

Hi I am trying to organize data for a report and using formulas dose not produce the results I am looking for, my VBA is very limited, please help. I need to copy first set of data and organize no next sheet. Please see example. Please help

DATA

Excel 2010
	A	B	C	D
1	Cat	Code	Item	Code2
2	VEGGIE CUPS	24212300000	JALAPENOS SLICED	1300003
3	VEGGIE CUPS	24209100000	GARLIC PEELED	1300002
4	VEGGIE CUPS	24204000000	TOMATO CUP	1300001
5	STUFFED MUSHROOMS	24201900000	MUSHROOMS VARIETY 6 CT	1200011
6	STUFFED MUSHROOMS	24215600000	MUSHROOMS SPINACH & MOZZARELLA 2 CT	1200008
7	STUFFED MUSHROOMS	24204200000	MUSHROOMS SPINACH & MOZZARELLA 6CT	1200007
8	VEGGIE CUPS	24210700000	DICED GREEN ONION CUP	1300008
9	VEGGIE CUPS	24214400000	CELERY/ONION DICED CUP	1300005
10	STUFFED MUSHROOMS	24201900000	MUSHROOMS VARIETY 6 CT	1200011
11	STUFFED MUSHROOMS	24215600000	MUSHROOMS SPINACH & MOZZARELLA 2 CT	1200008
12	SOUTHWESTERN	24236700000	SPICY GUACAMOLE FRESH	1100046
13	SOUTHWESTERN	24215500000	PICO DE GALLO	1100023
14	SOUTHWESTERN	24206700000	BEAN DIP 7 LAYER	1100014
15	SOUTHWESTERN	24200900000	MANGO SALSA	1100009
16	SOUTHWESTERN	24206400000	JALAPENOS STUFFED W/BACON	1100003
17	PARTY TRAYS	24210800000	PREMIUM VEGETABLE TRAY	1000012
18	PARTY TRAYS	24250100000	VEGETABLE TRAY W/DIP	1000007
19	PARTY TRAYS	24215100000	FRUIT TRAY W/DIP	1000005
20	GRAB & GO TRAYS	24218800000	BROCCOLI CARROTS CAULIFLOWER & DIP	800017
21	GRAB & GO TRAYS	24219000000	BROCCOLI CARROTS GRAPE TOMATOES & DIP	800015
22	GRAB & GO TRAYS	24218700000	APPLES CHEESE & DIP	800013
23	GRAB & GO TRAYS	24218900000	BROCCOLI CARROTS & CELERY W/DIP	800009
Sheet10

Desired output

Excel 2010
	G	H	I	J
2	VEGGIE CUPS
3		24212300000	JALAPENOS SLICED	1300003
4		24209100000	GARLIC PEELED	1300002
5		24204000000	TOMATO CUP	1300001
6	STUFFED MUSHROOMS
7		24201900000	MUSHROOMS VARIETY 6 CT	1200011
8		24215600000	MUSHROOMS SPINACH & MOZZARELLA 2 CT	1200008
9		24204200000	MUSHROOMS SPINACH & MOZZARELLA 6CT	1200007
10	VEGGIE CUPS
11		24210700000	DICED GREEN ONION CUP	1300008
12		24214400000	CELERY/ONION DICED CUP	1300005
13	STUFFED MUSHROOMS
14		24201900000	MUSHROOMS VARIETY 6 CT	1200011
15		24215600000	MUSHROOMS SPINACH & MOZZARELLA 2 CT	1200008
16	SOUTHWESTERN
17		24236700000	SPICY GUACAMOLE FRESH	1100046
18		24215500000	PICO DE GALLO	1100023
19		24206700000	BEAN DIP 7 LAYER	1100014
20		24200900000	MANGO SALSA	1100009
21		24206400000	JALAPENOS STUFFED W/BACON	1100003
22	PARTY TRAYS
23		24210800000	PREMIUM VEGETABLE TRAY	1000012
24		24250100000	VEGETABLE TRAY W/DIP	1000007
25		24215100000	FRUIT TRAY W/DIP	1000005
26	GRAB & GO TRAYS
27		24218800000	BROCCOLI CARROTS CAULIFLOWER & DIP	800017
28		24219000000	BROCCOLI CARROTS GRAPE TOMATOES & DIP	800015
29		24218700000	APPLES CHEESE & DIP	800013
30		24218900000	BROCCOLI CARROTS & CELERY W/DIP	800009
Sheet10

Thanks

 

[Ombir]

Zibi, here is another solution using Dictionary approach which should work faster than other ones. Give it a try.

Dim dict As Object
Sub Zibi() '20/05/16
Dim i As Long, j As Long, r As Long, s As Long
Dim iar() As Variant, ar As Variant
Dim rng As Range, cell As Range, Q() As Variant

lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Set dict = CreateObject("scripting.dictionary")

Application.ScreenUpdating = False

Set rng = Sheet1.Range("A2:A" & lr)
cnt = Uniq(rng): dict.RemoveAll

iar = Sheet1.Range("A2:D" & lr)

With dict
    For i = 1 To UBound(iar, 1)
        If Not .exists(iar(i, 1)) Then
            T = 1
            r = Application.WorksheetFunction.CountIf(rng, iar(i, 1)) + 1
            ReDim Q(1 To r, 1 To 5)
            Q(T, 1) = iar(i, 1): Q(T, 5) = T + 1
            Q(T + 1, 2) = iar(i, 2): Q(T + 1, 3) = iar(i, 3): Q(T + 1, 4) = iar(i, 4)
            .Item(iar(i, 1)) = Q
        Else
            ar = .Item(iar(i, 1))
            T = ar(LBound(ar), 5) + 1
            ar(T, 2) = iar(i, 2)
            ar(T, 3) = iar(i, 3)
            ar(T, 4) = iar(i, 4)
            ar(1, 5) = T
            .Item(iar(i, 1)) = ar
        End If
    Next
    
Sheet1.Range("G1:J" & cnt + lr).ClearContents
Sheet1.Range("G1:J1") = Array("Cat", "Code", "Item", "Code2")
r = 2

For Each k In .keys
    s = .Item(k)(1, 5)
    Sheet1.Cells(r, 7).Resize(s, 5) = .Item(k)
    r = r + s
Next
Sheet1.UsedRange.Columns.AutoFit
Sheet1.Columns("K").Delete
Set dict = Nothing
End With
Application.ScreenUpdating = True
End Sub
Public Function Uniq(rng As Range) As Long
    Dim cell As Range
    For Each cell In rng.Cells
         If Not dict.exists(cell.Value) Then
            dict.Add cell.Value, 0
        End If
    Next
    Uniq = dict.Count
End Function

 

[Ombir]

I used the function Uniq for another approach but there is no need in above one. Here is the revised version after removing Function (Uniq) :

Dim dict As Object
Sub Zibi() '20/05/16
Dim i As Long, j As Long, r As Long, s As Long
Dim iar() As Variant, ar As Variant
Dim rng As Range, cell As Range, Q() As Variant

lr = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Set dict = CreateObject("scripting.dictionary")

Application.ScreenUpdating = False

Set rng = Sheet1.Range("A2:A" & lr)
'cnt = Uniq(rng): dict.RemoveAll

iar = Sheet1.Range("A2:D" & lr)

With dict
    For i = 1 To UBound(iar, 1)
        If Not .exists(iar(i, 1)) Then
            T = 1
            r = Application.WorksheetFunction.CountIf(rng, iar(i, 1)) + 1
            ReDim Q(1 To r, 1 To 5)
            Q(T, 1) = iar(i, 1): Q(T, 5) = T + 1
            Q(T + 1, 2) = iar(i, 2): Q(T + 1, 3) = iar(i, 3): Q(T + 1, 4) = iar(i, 4)
            .Item(iar(i, 1)) = Q
        Else
            ar = .Item(iar(i, 1))
            T = ar(LBound(ar), 5) + 1
            ar(T, 2) = iar(i, 2)
            ar(T, 3) = iar(i, 3)
            ar(T, 4) = iar(i, 4)
            ar(1, 5) = T
            .Item(iar(i, 1)) = ar
        End If
    Next
    
Sheet1.Range("G1").CurrentRegion.ClearContents
Sheet1.Range("G1:J1") = Array("Cat", "Code", "Item", "Code2")
r = 2

For Each k In .keys
    s = .Item(k)(1, 5)
    Sheet1.Cells(r, 7).Resize(s, 5) = .Item(k)
    r = r + s
Next
Sheet1.UsedRange.Columns.AutoFit
Sheet1.Columns("K").Delete
Set dict = Nothing
End With
Application.ScreenUpdating = True
End Sub

 

[Zibi]

Hi the query looks nice but for some reason it stops at:


Q(T + 1, 2) = iar(i, 2):


Can you please advise?

Thanks

 

[Ombir]

Zibi,

I hard coded it to work with 1st sheet (irrespective of its name) of your workbook on basis of index. May be you're trying to run in a different worksheet. Here is the modified version which will work with Sheet name "Sheet1."

Dim dict As Object
Sub Zibi() '20/05/16
Dim ws As Worksheet
Dim i As Long, j As Long, r As Long, s As Long
Dim iar() As Variant, ar As Variant
Dim rng As Range, cell As Range, Q() As Variant

Set ws = Worksheets("Sheet1")

lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set dict = CreateObject("scripting.dictionary")

Application.ScreenUpdating = False

Set rng = ws.Range("A2:A" & lr)

iar = ws.Range("A2:D" & lr)

With dict
    For i = 1 To UBound(iar, 1)
        If Not .exists(iar(i, 1)) Then
            T = 1
            r = Application.WorksheetFunction.CountIf(rng, iar(i, 1)) + 1
            ReDim Q(1 To r, 1 To 4)
            Q(T, 1) = iar(i, 1)
            Q(T + 1, 2) = iar(i, 2): Q(T + 1, 3) = iar(i, 3): Q(T + 1, 4) = iar(i, 4)
            .Item(iar(i, 1)) = Array(Q, T + 1)
        Else
            ar = .Item(iar(i, 1))
            T = ar(1) + 1
            ar(0)(T, 2) = iar(i, 2)
            ar(0)(T, 3) = iar(i, 3)
            ar(0)(T, 4) = iar(i, 4)
            .Item(iar(i, 1)) = Array(ar(0), T)
        End If
    Next
    
ws.Range("G1").CurrentRegion.ClearContents
ws.Range("G1:J1") = Array("Cat", "Code", "Item", "Code2")
r = 2

For Each K In .keys
    s = .Item(K)(1)
    ws.Cells(r, 7).Resize(s, 4) = .Item(K)(0)
    r = r + s
Next
ws.UsedRange.Columns.AutoFit
Set dict = Nothing
End With
Application.ScreenUpdating = True
End Sub

 

[Zibi]

perfect thanks for helping