collection columns and delete other for 8000 rows

[Maklil]

Hi

I search for macro to merge duplicates items for 8000 rows . so I want merge duplicates items based on column B for each sheet individually .

in sheet purchase ,sell just I want merging column B,E .so in sheet output should merge duplicates items , values for sheet PURCHSE and put in column C. as to sheet SELL should merge duplicates items , values and put in column D and show the BALANCE in column E as I put the formula . every time when run the macro should clear data from row2 before brings data .

items.xlsx
	A	B	C	D	E
1	DATE	ITEM	CUSTOMER	INV NO	QTY
2	11/11/19	ITTT-100/AS-1	CSS-100	INV-A123	200
3	12/11/19	ITTT-100/AS-2	CSS-101	INV-A124	300
4	13/11/19	ITTT-100/AS-3	CSS-102	INV-A125	400
5	14/11/19	ITTT-100/AS-4	CSS-103	INV-A126	500
6	15/11/19	ITTT-100/AS-5	CSS-104	INV-A127	600
7	16/11/19	ITTT-100/AS-6	CSS-105	INV-A128	700
8	17/11/19	ITTT-100/AS-7	CSS-100	INV-A129	800
9	18/11/19	ITTT-100/AS-4	CSS-107	INV-A130	900
10	19/11/19	ITTT-100/AS-5	CSS-108	INV-A131	1000
11	20/11/19	ITTT-100/AS-6	CSS-109	INV-A132	1100
12	21/11/19	ITTT-100/AS-7	CSS-110	INV-A133	1200
13	22/11/19	ITTT-100/AS-1	CSS-111	INV-A134	1300
14	23/11/19	ITTT-100/AS-2	CSS-112	INV-A135	1400
15	24/11/19	ITTT-100/AS-3	CSS-102	INV-A136	1500
16	25/11/19	ITTT-100/AS-8	CSS-107	INV-A137	1600
17	26/11/19	ITTT-100/AS-10	CSS-108	INV-A138	1601
PURCHSE

items.xlsx
	A	B	C	D	E
1	DATE	ITEM	CLIENT	INV NO	QTY
2	30/11/19	ITTT-100/AS-8	CLS-100	INV-AT10	100
3	01/12/19	ITTT-100/AS-5	CLS-101	INV-AT11	120
4	02/12/19	ITTT-100/AS-6	CLS-102	INV-AT12	140
5	03/12/19	ITTT-100/AS-4	CLS-103	INV-AT13	160
6	04/12/19	ITTT-100/AS-5	CLS-104	INV-AT14	180
7	05/12/19	ITTT-100/AS-5	CLS-105	INV-AT15	200
8	06/12/19	ITTT-100/AS-7	CLS-106	INV-AT16	220
9	07/12/19	ITTT-100/AS-4	CLS-107	INV-AT17	240
10	08/12/19	ITTT-100/AS-5	CLS-108	INV-AT18	260
11	09/12/19	ITTT-100/AS-6	CLS-109	INV-AT19	280
12	10/12/19	ITTT-100/AS-7	CLS-110	INV-AT20	300
13	12/12/19	ITTT-100/AS-2	CLS-112	INV-AT22	340
14	14/12/19	ITTT-100/AS-8	CLS-114	INV-AT24	380
15	15/12/19	ITTT-100/AS-9	CLS-115	INV-AT25	381
SELL

items.xlsx
	A	B	C	D	E
1	ITEM	BRAND	PURCHASE	SELL	BALANCE
2	1	ITTT-100/AS-1	1500	-	1500
3	2	ITTT-100/AS-2	1700	340	1360
4	3	ITTT-100/AS-3	1900	-	1900
5	4	ITTT-100/AS-4	1400	400	1000
6	5	ITTT-100/AS-5	1600	500	1100
7	6	ITTT-100/AS-6	1800	420	1380
8	7	ITTT-100/AS-7	2000	300	1700
9	8	ITTT-100/AS-8	-	480	-480
10	9	ITTT-100/AS-9	-	381	-381
11	10	ITTT-100/AS-10	1061		1061
OUTPUT

Cell Formulas
Range	Formula
E2:E11	E2	=C2-D2

thanks

 

[mohadin]

help me sorting data based on ID in column B

Sub test()
    Dim a, itm, k, w
    Dim i&
    a = Sheets("PURCHSE").Cells(1).CurrentRegion
    With CreateObject("scripting.dictionary")
        For i = 2 To UBound(a)
            If a(i, 2) <> 0 Then
                If Not .exists(a(i, 2)) Then
                    .Add a(i, 2), Array(a(i, 2), a(i, 5), 0, a(i, 5))
                Else
                      w = .Item(a(i, 2))
                      w(1) = w(1) + a(i, 5)
                      w(3) = w(1) - w(2)
                      .Item(a(i, 2)) = w
                End If
            End If
        Next
         a = Sheets("SEll").Cells(1).CurrentRegion
         For i = 2 To UBound(a)
            If a(i, 2) <> 0 Then
                If .exists(a(i, 2)) Then
                     w = .Item(a(i, 2))
                      w(2) = w(2) + a(i, 5)
                       w(3) = w(1) - w(2)
                      .Item(a(i, 2)) = w
                Else
                  .Add a(i, 2), Array(a(i, 2), 0, a(i, 5), -a(i, 5))
                End If
            End If
        Next
        k = .Count:  itm = .items
      End With
      a = Application.Index(itm, 0, 0)
        ReDim Preserve a(1 To UBound(a), 1 To UBound(a, 2) + 1)
        For i = 1 To UBound(a)
        a(i, UBound(a, 2)) = Format$(Split(a(i, 1), "-")(2), String(12, "0"))
        Next
        a = BubleSort(a, 5)
        With Sheets("OUTPUT")
        .Cells(1).CurrentRegion.ClearContents
        .Cells(1, 1).Resize(, 5) = Array("Item", "BRAND", "PURCHASE", "SELL", "BALANCE")
        .Cells(2, 1).Resize(k) = Application.Evaluate("row(1:" & k & ")")
        .Cells(2, 2).Resize(k, 4) = a
    End With
End Sub

Function BubleSort(a As Variant, s_col As Integer)
Dim lb&, ub&, ub2&, lb2&, i&, ii&
Dim flag As Boolean
Dim temp
    lb = LBound(a, 1): ub = UBound(a, 1): ub2 = UBound(a, 2): lb2 = LBound(a, 2)
    flag = True
    Do While flag
        flag = False
        For ii = lb To ub - 1
            If a(ii, s_col) = 0 Then a(ii, s_col) = 100000 Else
            If a(1 + ii, s_col) < a(ii, s_col) Then
                flag = True
                For i = lb2 To ub2: temp = a(1 + ii, i):  a(1 + ii, i) = a(ii, i):  a(ii, i) = temp
                Next i
            End If
        Next ii
    Loop
    BubleSort = a
End Function

 

[Maklil]

@mohadin
really thanks for your time and assistance .

 

[mohadin]

You are very welcome
And thank you for the feedback
Be happy and safe

 

[alansidman]

Been travelling and no internet. Do you have a table1 identified. What are your table names.