Ideas to help modified code to work with different conditions

Oberon70

Oberon70

Board Regular
Joined
Jan 21, 2022
Messages
160
Office Version
  1. 365
Platform
  1. Windows
I previously was provided with a code that took the information from a table with the below structure:

Claim NumberAmountINVOICE IDTRANSACTION TYPE
ID5045209893Trust Payment
ID5046-209893Trust Payment
ID5039809893Trust Payment
ID4892-383.048314Commission
ID48991008314Trust Payment
ID4892497.468314Trust Payment
ID5001-208314Trust Payment
ID5020-889.528315Commission
ID5021-48.118315Commission
ID5022-81.598315Commission
ID5023-36.268315Commission
ID5025-888.038315Commission
ID502197.198315Trust Payment
ID5022164.828315Trust Payment
ID502373.248315Trust Payment
ID502517948315Trust Payment
ID50263008348Trust Payment
ID5027-67.28348Trust Payment


However, this worked well, when I was processing a full statement. Now, my work has implemented auto receipting and I receive a Data file that has a list of all the rejected transactions. This file can be made up of different agents and invoice numbers, plus can have transaction reversals.

I have written code to load the Data file and insert the information into a table. The table looks like the below:

Rejected Transactions - Consolidated
CLAIM NUMBERAgency NameAMOUNTINVOICE IDTRANSACTION TYPE
ID5041 Star Interprise Inc209893Trust Payment
ID5045 Star Interprise Inc209893Trust Payment
ID5046 Star Interprise Inc-209893Trust Payment
ID5039 Star Interprise Inc809893Trust Payment
ID4892Star Labs -383.048314Commission
ID4899Star Labs 1008314Trust Payment
ID4892Star Labs 497.468314Trust Payment
ID5005Star Labs -5308314Trust Payment
ID5022Star Labs -81.598315Commission
ID5023Star Labs -36.268315Commission
ID5025Star Labs -888.038315Commission
ID5021Star Labs 97.198315Trust Payment
ID5022Star Labs 164.828315Trust Payment
ID5023Star Labs 73.248315Trust Payment
ID5025Star Labs 17948315Trust Payment
ID5026Star Labs 3008348Trust Payment
ID5027Star Labs -67.28348Trust Payment
ID3005Star Labs -27.58354Commission
ID300909 Star Labs -118354Commission
ID0010200132Star Labs -766.158359Commission
ID5036 Star Labs -297.778359Commission
ID5037 Star Labs -7.78359Commission
ID5036 Star Labs 773.438359Trust Payment
ID0010200132Star Labs 19908359Trust Payment
ID5038 Star Labs -49.58361Commission
ID0010224563Star Labs -59.48361Commission
ID5038 Star Labs 1008361Trust Payment
ID0010224563Star Labs 1208361Trust Payment
ID5043 Wayne Enterprise-7711093Commission
ID5044 Wayne Enterprise-308011093Commission
ID5047 Wayne Enterprise-38.511093Commission
ID5039 Wayne Enterprise32011093Trust Payment
ID5041 Wayne Enterprise8011093Trust Payment
ID5044 Wayne Enterprise800011093Trust Payment
ID5046 Wayne Enterprise-4011093Trust Payment
ID5047 Wayne Enterprise10011093Trust Payment


Original.xlsm
ABCIZAAABACADAEAFAGAHAIAJ
1Claim NumberAmountInc CommStar Labs 9893
2ID500510-4.55Click MeKID500510
3ID500620-10.55KID500620
4ID500830-16.55KID500830
5ID501040-22.55KID501040
6ID501150-28.55KID501150
7ID501260-34.55KID501260
8ID501370-40.55KID501370
9ID501580-46.55KID501580
10ID501890-52.55KID501890
11ID5019100-58.55KID5019100
12ID5020110-64.55KID5020110
13ID5021120-70.55KID5021120
14ID5022130-76.55KID5022130
15ID5023140-82.55KID5023140
16ID5025150-88.55KID5025150
17ID5006160-94.55KID5006160
18ID5010170-100.55
19ID5011180-106.55Click MeN1ID500590p4.553Commission
20ID5012190-112.55Click MeN1ID501390p40.553Commission
21ID5013200-118.55Click MeN1ID502290p76.553Commission
22ID5015210-124.55
23ID5018220-130.55
24ID5019230-136.55Click Me-10payment ID5005
25ID5021240-142.55-4.55Commission
26ID5022250-148.55-20payment ID5006
27ID5023260-154.55-10.55Commission
28ID5025270-160.55-30payment ID5008
29ID5026280-166.55-16.55Commission
30ID5027290-172.55-40payment ID5010
31ID5028300-178.55-22.55Commission
32ID5029310-184.55-50payment ID5011
33ID5031320-190.55-28.55Commission
34ID5032330-196.55-60payment ID5012
35ID5033340-202.55-34.55Commission
36ID5034350-208.55
37ID3005360-214.55Click Me-70payment ID5013
38ID5036370-220.55-40.55Commission
39ID5037380-226.55-80payment ID5015
40ID5036390-232.55-46.55Commission
41ID5026400-238.55-90payment ID5018
42ID5037410-244.55-52.55Commission
43ID5038420-250.55-100payment ID5019
44ID5038430-256.55-58.55Commission
45ID5039440-262.55-110payment ID5020
46ID5041450-268.55-64.55Commission
47ID5043460-274.55-120payment ID5021
48ID5043470-280.55-70.55Commission
49ID5044480-286.55
50ID5044490-292.55Click Me-130payment ID5022
51ID5045500-298.55-76.55Commission
52ID5046510-304.55-140payment ID5023
53ID5047520-310.55-82.55Commission
54ID5047530-316.55-150payment ID5025
55ID5041540-322.55-88.55Commission
56ID5045550-328.55-160payment ID5006
57ID5046560-334.55-94.55Commission
58ID5039570-340.55Receipt NumHide me
Rapid Receipting


The 1st section is for payments only. So, the max amount of payments is 16 and the payments can not be a negative amount (reversal).

Original.xlsm
AAABACAD
1Star Labs 9893
2Click MeKID500510
3KID500620
4KID500830
5KID501040
6KID501150
7KID501260
8KID501370
9KID501580
10KID501890
11KID5019100
12KID5020110
13KID5021120
14KID5022130
15KID5023140
16KID5025150
17KID5006160
Rapid Receipting


the 2nd section was originally only for commission but now will need to include payment reversals and commission.

Original.xlsm
AAABACADAEAFAGAHAIAJAKALAMANAO
19Click MeN1ID500590p-4.553CommissionN1ID500690p-10.55
20Click MeK1ID501395p-40.554PaymentK1ID501595p-46.55
Rapid Receipting


the third section is fine as it is just the previous data but in reverse. i.e. payment $10.00 would be -10.00 in section three.

Original.xlsm
AAABACADAE
24Click Me-10payment ID5005
25-4.55Commission
26-20payment ID5006
27-10.55Commission
28-30payment ID5008
29-16.55Commission
30-40payment ID5010
31-22.55Commission
32-50payment ID5011
33-28.55Commission
34-60payment ID5012
35-34.55Commission
Rapid Receipting


The original code is:

VBA Code: 
Sub RapidReceipting()

     Dim i0, i, i1, s, iSet, iTotal, a, O1(), O2(), O3(), sh, Lrow
     Dim AbrAgntNme As String
     Dim wsInvDTL As Worksheet
     Dim wsSpdRcpt As Worksheet
     Dim wb As Workbook
     
     Set wb = ActiveWorkbook
     Set wsInvDTL = wb.Sheets("Invoice Details")
     Set wsSpdRcpt = wb.Sheets("Rapid Receipting")
     
     AbrAgntNme = wb.Sheets("Invoice Details").Range("B1")
     
     iSet = 16                                                  'groupsize

     With Range("TBL_Claims").ListObject
          a = .DataBodyRange.Value                              'read the values of this table (size unknown)
          Set sh = .Parent                                      'the sheet, that range (listobject) is in
     End With

     sh.UsedRange.Offset(, 9).Clear                             'Contents                     'clear everything at the RHS of our table

     For i = 0 To (UBound(a) - 1) / iSet                        'outer loop for the sets of 16
          ReDim O1(1 To iSet, 1 To 2)                           'start with fresh (=empty) & correct sized arrays !!!
          ReDim O2(1 To WorksheetFunction.RoundUp((iSet - 1) / 6, 0), 1 To 24)
          ReDim O3(1 To 3 * iSet, 1 To 2)

     '1st part = make per 16 3 sets of arrays (O1 to O3) ready for output
     '***************************************************
          For i1 = 1 To iSet                                    'inner loop (until 16 in case of a complete set)

               ptr = i * iSet + i1                              'pointer to know the right row in a
               If ptr > UBound(a) Then Exit For
     '1st array =16 rows with claimcounter and amount
               O1(i1, 1) = "K" & a(ptr, 1)
               O1(i1, 2) = a(ptr, 2)

     '2nd array=3 rows * 6 columns "N" & claimnumber

               ptr1 = (i1 - 1) \ 6: ptr2 = i1 - (ptr1 * 6)
               ptr3 = 1 + ptr1: ptr4 = (ptr2 - 1) * 4 + 1

               O2(ptr3, ptr4) = "N1" & a(ptr, 1)
               O2(ptr3, ptr4 + 1) = "90p"
               O2(ptr3, ptr4 + 2) = a(ptr, 3)
               O2(ptr3, ptr4 + 3) = "3Commission"

     '3rd array=alternate -amount & "payment"   /    + inc Comm & "commission"
               O3((i1 - 1) * 2 + 1, 1) = -a(ptr, 2)
               O3((i1 - 1) * 2 + 1, 2) = "payment " & a(ptr, 1)
               O3(i1 * 2, 1) = a(ptr, 3)
               O3(i1 * 2, 2) = "Commission"
          Next

     '2nd part = write those 3 arrays (O1 to O3) to the sheet
     '***************************************************
          With sh.Cells(1 + 60 * i, "AA")
               .Value = wsInvDTL.Range("B1").Value & " " & wsInvDTL.Range("B2").Value
               .Offset(1, 2).Resize(UBound(O1), UBound(O1, 2)).Value = O1     '1st array = claimcounter & amount
               With .Offset(18, 2)                              '2nd array
                    For i3 = 1 To UBound(O2, 2)                 'loop tthrough all columns in the array
                         With .Offset(, 2 * (i3 - 1)).Resize(3, 1)     'skip everytime a column
                              .Value = Application.Index(O2, 0, i3)     'column with values
                              .Offset(, 1).Interior.Color = IIf(i3 = UBound(O2, 2), RGB(255, 0, 0), IIf(i3 Mod 4 = 0, RGB(0, 255, 0), RGB(200, 200, 200)))     'next columns with backgroundcolor
                         End With
                    Next

               End With
               
               With .Offset(23, 2)
                    For i3 = 1 To 3
                         With .Offset((i3 - 1) * 13).Resize(12, 3)
                              .Value = Application.Index(O3, WorksheetFunction.Sequence(12, 1, (i3 - 1) * 12 + 1), Array(1, 2, 2))     'copy the 2nd column twice as column 2 and 3
                              .Columns(2).ClearContents         'delete the 2nd column
                         End With
                    Next
               End With
               

               With .Range("A2,A19:A21,A24,A37,A50")
                    .Value = "Click Me"
                    .Interior.Color = vbYellow
               End With
               
               With .Range("A58")
                    .Value = "Hide me"
                    .Interior.Color = vbRed
               End With
               
              wsSpdRcpt.Range("A58").Offset(0, 8) = "Receipt Num"
               

               With .Offset(58).Resize(, 60).Borders(xlEdgeBottom)
                    .LineStyle = xlDouble
                    .Color = -16776961
                    .Weight = xlThick
               End With
             
          End With
          
     Next
     
     'wsRcptRpt.Range("B4").FormulaR1C1 = "=SUM(TBL_Claims[Amount])-SUM(TBL_Claims[Inc Comm])"
     'wsSpdRcpt.Range("A2").Offset(0, 8) = "Date"
     'wsSpdRcpt.Range("A3").Offset(0, 8) = "Batch"

     With sh.UsedRange.EntireColumn
          .ColumnWidth = 2
          .AutoFit                                              'adjust columnwidth
     End With
     sh.Columns("A:Y").EntireColumn.Hidden = True

End Sub

Any ideas on how to do the above would be great. I have been away from work on medical leave for two weeks due to surgery and getting this change will help me go through all the rejected transactions Data files and quickly get them receipted to the system.
 

Excel Facts

VLOOKUP to Left?
Use =VLOOKUP(A2,CHOOSE({1,2},$Z$1:$Z$99,$Y$1:$Y$99),2,False) to lookup Y values to left of Z values.
You must log in or register to reply here.

Similar threads

M
  • Solved
Please help to code has debug.
Replies
5
Views
119
motilulla
M
M
  • Question
Help making code faster
Replies
3
Views
311
michaelsmith559
M
RAJESH1960
  • Solved
Conditional formatting gone wrong
Replies
6
Views
529
Toadstool
Toadstool
Oberon70
  • Question
Thoughts on how to proceed or accomplish a batch report being created
Replies
0
Views
409
Oberon70
Oberon70
dss28
  • Question
VBA excel code for saving task with frequency based on incremental date value
Replies
3
Views
787
dss28
dss28

Forum statistics

Threads
1,214,827
Messages
6,121,823
Members
449,049
Latest member
cybersurfer5000

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