need macro to deal with 8000 rows to merge items based on helper column

O

Omran Y

New Member
Joined
Jul 17, 2023
Messages
39
Office Version
  1. 2013
Platform
  1. Windows
Hello experts

I look forward from the experts to write macro to deal with more than 8000 rows based on helper column.

I need match helper column (F) with column B based on part of the item , if the part of item in helper column F is matched with column B then should merge for column C,D and insert column E to calculate as I put the formula, but I don't need formula. Also will increase data A:D in BANK sheet and will add more from parts of items in helper column . so I want clear data from row2 in OPERATION sheet when run the macro every time before populate & merge data.
ZX.xlsm
ABCDEF
1DATEOPERATION NAMEDEBITCREDITOPERATION NAME
201/03/2023FIRST BALANCE DATE 31/12/202210,000.00FIRST BALANCE
301/03/2023BB IN TPUT R400-99 CASH PREPAID10,000.00CASH PREPAID
402/03/2023CASH PREPAID BB IN TPUT MM2002,000.00BANK SWIFT
503/03/2023BANK SWIFT FG-100030,000.00PAID BANK
604/03/2023MS.9888888 BANK SWIFT FG-100160,000.00CASH PIAD
705/03/2023PAID BANK MTSWF900002,000.00
806/03/2023BANK SWIFT FGS-1000110,000.00
907/03/2023 CASH PREPAID BB IN TPUT LM7000030,000.00
1008/03/2023INN70000 CASH PIAD6,000.00
1109/03/2023CASH PIAD MN9000 UY6001,000.00
12
BANK



ZX.xlsm
ABCDE
1ITEMOPERATION NAMEDEBITCREDITBALANCE
2
3
4
5
6
OPERATION



expected
ZX.xlsm
ABCDE
1ITEMOPERATION NAMEDEBITCREDITBALANCE
21FIRST BALANCE DATE 31/12/202210,000.0010,000.00
32CASH PREPAID42,000.0052,000.00
43BANK SWIFT100,000.00152,000.00
54PAID BANK2,000.00150,000.00
65CASH PIAD7,000.00143,000.00
OPERATION
Cell Formulas
RangeFormula
E2E2=C2-D2
E3:E6E3=E2+C3-D3


thank you
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
Sort by date Sort by votes
@Omran Y, welcome to MrExcel.
Try this:
VBA Code: 
Sub Omran_1()

Sheets("BANK").Activate
va = Range("B2:D" & Cells(Rows.Count, "B").End(xlUp).Row)
vc = Range("F2", Cells(Rows.Count, "F").End(xlUp))
   
ReDim vb(1 To UBound(vc, 1), 1 To 5)
For k = 1 To UBound(vc, 1)
    vb(k, 1) = k
    vb(k, 2) = vc(k, 1)
   
    For i = 1 To UBound(va, 1)
        If InStr(1, va(i, 1), vc(k, 1), vbTextCompare) Then
            vb(k, 3) = vb(k, 3) + va(i, 2)
            vb(k, 4) = vb(k, 4) + va(i, 3)
            va(i, 1) = Empty
        End If
    Next
Next

vb(1, 5) = vb(1, 3) - vb(1, 4)

For i = 2 To UBound(vb, 1)
    vb(i, 5) = vb(i - 1, 5) + vb(i, 3) - vb(i, 4)
Next

With Sheets("OPERATION")
    .Range("A2:E10000").ClearContents
    .Range("A2").Resize(UBound(vb, 1), 5) = vb
End With

End Sub

Result:
Omran Y #1.xlsm
ABCDE
1ITEMOPERATION NAMEDEBITCREDITBALANCE
21FIRST BALANCE10000010000
32CASH PREPAID42000052000
43BANK SWIFT1000000152000
54PAID BANK02000150000
65CASH PIAD07000143000
OPERATION


The code worked on your sample, but in your actual data is there any item on the list in the helper column (col F) that is part of another item? for example "PAID BANK" & "REPAID BANK". If that is the case then we need to amend the code to accordingly.
 
Upvote 0
@Omran Y
Here's a revised version. I'm utilizing regex to address the potential problem described in the previous post, so you don't have to worry about it.
VBA Code: 
Sub Omran_2()
Dim regEx As Object
Dim va, vb, vc
Dim i As Long, k As Long

Sheets("BANK").Activate
va = Range("B2:D" & Cells(Rows.Count, "B").End(xlUp).Row)
vc = Range("F2", Cells(Rows.Count, "F").End(xlUp))  'keyword list
ReDim vb(1 To UBound(vc, 1), 1 To 5)

       Set regEx = CreateObject("VBScript.RegExp")
        With regEx
            .Global = False
            .MultiLine = False
            .IgnoreCase = True
        End With

For k = 1 To UBound(vc, 1) 'loop keyword list
    vb(k, 1) = k
    vb(k, 2) = vc(k, 1)
    regEx.Pattern = "\b" & vc(k, 1) & "\b"
        For i = 1 To UBound(va, 1)
            If regEx.test(va(i, 1)) Then
                vb(k, 3) = vb(k, 3) + va(i, 2)
                vb(k, 4) = vb(k, 4) + va(i, 3)
                va(i, 1) = Empty
            End If
        Next
Next

vb(1, 5) = vb(1, 3) - vb(1, 4)

For i = 2 To UBound(vb, 1)
    vb(i, 5) = vb(i - 1, 5) + vb(i, 3) - vb(i, 4)
Next

With Sheets("OPERATION")
    .Range("A2:E10000").ClearContents
    .Range("A2").Resize(UBound(vb, 1), 5) = vb
End With

End Sub
 
Upvote 1
wow !
this is awesome ,seem to work excellently!
thank you so much genius .
 
Upvote 0
You're welcome, glad to help & thanks for the feedback.:)
 
Upvote 0
Hi
can you modify your code to insert TOTAL row and could be like this ,please?
ZX.xlsm
ABCDE
1ITEMOPERATION NAMEDEBITCREDITBALANCE
21FIRST BALANCE10,000.000.0010,000.00
32CASH PREPAID42,000.000.0052,000.00
43BANK SWIFT100,000.000.00152,000.00
54PAID BANK0.002,000.00150,000.00
65CASH PIAD0.007,000.00143,000.00
7TOTAL152,000.009,000.00143,000.00
OPERATION
Cell Formulas
RangeFormula
C7:D7C7=SUM(C2:C6)
E7E7=C7-D7
 
Upvote 0
Omran Y said:
Hi Akuini
can you see my request ,please?
Click to expand...
Sorry, I forgot to follow up your inquiry.
Try this:
VBA Code: 
Sub Omran_3()
Dim regEx As Object
Dim va, vb, vc
Dim i As Long, k As Long, n As Long

Sheets("BANK").Activate
va = Range("B2:D" & Cells(Rows.Count, "B").End(xlUp).Row)
vc = Range("F2", Cells(Rows.Count, "F").End(xlUp))  'keyword list
ReDim vb(1 To UBound(vc, 1), 1 To 5)

       Set regEx = CreateObject("VBScript.RegExp")
        With regEx
            .Global = False
            .MultiLine = False
            .IgnoreCase = True
        End With

For k = 1 To UBound(vc, 1) 'loop keyword list
    vb(k, 1) = k
    vb(k, 2) = vc(k, 1)
    regEx.Pattern = "\b" & vc(k, 1) & "\b"
        For i = 1 To UBound(va, 1)
            If regEx.test(va(i, 1)) Then
                vb(k, 3) = vb(k, 3) + va(i, 2)
                vb(k, 4) = vb(k, 4) + va(i, 3)
                va(i, 1) = Empty
            End If
        Next
Next

vb(1, 5) = vb(1, 3) - vb(1, 4)

For i = 2 To UBound(vb, 1)
    vb(i, 5) = vb(i - 1, 5) + vb(i, 3) - vb(i, 4)
Next

Sheets("OPERATION").Activate
    
    

    Range("A2:E10000").ClearContents
    Range("A2").Copy Range("A2:A10000")
    Range("A2").Resize(UBound(vb, 1), 5) = vb

n = Range("A" & Rows.Count).End(xlUp).Row + 1
'Range("C" & n - 1).Resize(, 3).Copy Range("C" & n)
Range("C" & n) = WorksheetFunction.Sum(Range("C2:C" & n - 1))
Range("D" & n) = WorksheetFunction.Sum(Range("D2:D" & n - 1))
Range("E" & n) = WorksheetFunction.Sum(Range("C" & n) - Range("D" & n))

With Range("A" & n)
    .Value = "TOTAL"
    .Font.Color = vbRed
    .Font.Bold = True
    .Interior.Color = vbYellow
End With

End Sub


To get the number format in col C:E as you wanted, just do it manually before you run the macro, you just need to do it once.
 
Upvote 1
thanks again
just I see creating borders without any necessary why create borders in the whole column A, how I can delete it ?
just I want based on filled in cells .
this is what got in column A
دمج حسابات الخزينة واحتساب رصيدها.xlsm
ABCDE
1ITEMOPERATION NAMEDEBITCREDITBALANCE
21FIRST BALANCE10,000.000.0010,000.00
32CASH PREPAID42,000.000.0052,000.00
43BANK SWIFT100,000.000.00152,000.00
54PAID BANK0.002,000.00150,000.00
65CASH PIAD0.007,000.00143,000.00
7TOTAL152,000.009,400.00142,600.00
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
OPERATION
 
Last edited by a moderator:
Upvote 0
Try:
To get the format in col A:E as you wanted, just do it manually for A2:E2 before you run the macro, you just need to do it once.
VBA Code: 
Sub Omran_4()
Dim regEx As Object
Dim va, vb, vc
Dim i As Long, k As Long, n As Long

Sheets("BANK").Activate
va = Range("B2:D" & Cells(Rows.Count, "B").End(xlUp).Row)
vc = Range("F2", Cells(Rows.Count, "F").End(xlUp))  'keyword list
ReDim vb(1 To UBound(vc, 1), 1 To 5)

       Set regEx = CreateObject("VBScript.RegExp")
        With regEx
            .Global = False
            .MultiLine = False
            .IgnoreCase = True
        End With

For k = 1 To UBound(vc, 1) 'loop keyword list
    vb(k, 1) = k
    vb(k, 2) = vc(k, 1)
    regEx.Pattern = "\b" & vc(k, 1) & "\b"
        For i = 1 To UBound(va, 1)
            If regEx.test(va(i, 1)) Then
                vb(k, 3) = vb(k, 3) + va(i, 2)
                vb(k, 4) = vb(k, 4) + va(i, 3)
                va(i, 1) = Empty
            End If
        Next
Next

vb(1, 5) = vb(1, 3) - vb(1, 4)

For i = 2 To UBound(vb, 1)
    vb(i, 5) = vb(i - 1, 5) + vb(i, 3) - vb(i, 4)
Next

Sheets("OPERATION").Activate
    
    
    Range("A2:E2").ClearContents
    Range("A3:E10000").Clear
    Range("A2").Resize(UBound(vb, 1), 5) = vb

n = Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A2:E2").Copy
Range("A3:E" & n).PasteSpecial xlPasteFormats

Range("C" & n) = WorksheetFunction.Sum(Range("C2:C" & n - 1))
Range("D" & n) = WorksheetFunction.Sum(Range("D2:D" & n - 1))
Range("E" & n) = WorksheetFunction.Sum(Range("C" & n) - Range("D" & n))



With Range("A" & n)
    .Value = "TOTAL"
    .Font.Color = vbRed
    .Font.Bold = True
    .Interior.Color = vbYellow
End With

End Sub
 
Upvote 1
Solution
You must log in or register to reply here.

Similar threads

O
  • Solved
delete 8000 rows based on what I write items in helper column
2 3 4
Replies
33
Views
1K
Peter_SSs
Peter_SSs
O
  • Question
calculation amounts for BANK & CASH across sheets based on matching partial item
Replies
0
Views
45
Omran Y
O
A
  • Solved
split & delete characters into multiple sheets based on helper column
Replies
6
Views
275
Abdo
A
A
  • Solved
split range into multiple range based on blank row for each range
Replies
4
Views
345
Ali M
A
O
  • Question
sum or subtract for the same cell based on match column between two sheets
2
Replies
13
Views
451
Omran Y
O

Forum statistics

Threads
1,215,092
Messages
6,123,063
Members
449,090
Latest member
fragment

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top