Help with For Loop - works great except for the last bit

Oberon70

Board Regular
Joined
Jan 21, 2022
Messages
160
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have a loop that moves the data into different format, so I can paste it into a system.

The loop is working great until the end.

section 1 of the loop has 16 items on one page.
Section 2 has 2 lots of 6 and last page 4.

So lets say I have 155 transactions that equates to set of 9 complete sets of 16 and the last set being 11
The same if I have 70 transactions that equates to to 4 complete sets of 16 and the last set being 6.

The 1st part of my code I was able to get the loop to recognise that the last section needs to be the remaining number from the transaction. Basically, I subtracted 16 from the transaction until the count was created than the transaction then I over rode the final loop on section one to equal the number of transactions left, but I can't seem to figure how to do this on the 2nd part.

I really hope someone can help me on this. so lets say the below was 27 transactions, 1st section of the code reduce the last section to 11, but the 2nd part still is completing the all three loops, were it need to only do two loops and one less entry. sorry, hope this make since.

1648781930315.png



VBA Code:
Sub CrtWorkFlw()

Dim lastrow As Double
Dim AgtName As String
Dim InvNum As String
Dim TransCnt As Double 'The total count of transactions being looped.
Dim Mloop As Double 'The start of the main loop through the transactions
Dim Tloop As Double 'The start of the loop for recovered funds
Dim rNum As Double 'this is for the row Location for data to be entered on the spreadsheet cells(rNum, cNum)
Dim cNum As Double 'this is for the column Location for data to be entered on the spreadsheet cells(rNum, cNum)
Dim clcnt2 As Double 'variable to assist with the location of the data being sorted.
Dim clcnt As Double
Dim nLoop As Double 'How many loops through the code that the main loop will do.
Dim TloopCnt As Double  'what the recvovred funds are counting down too.
Dim cc As Double 'variable used to asssit with keeping track if there is less than 16 entries left to loop through.
Dim dd As Double



Dim CommLoop As Double
Dim CommLoop2 As Double
Dim CommLoop3 As Double


Dim CommLoopCnt As Double
Dim CommLoopCnt2 As Double


lastrow = wsSupSheet.Cells(Rows.Count, "A").End(xlUp).Row

AgtName = Trim(wsInvDtls.Range("B3").Value)
InvNum = wsInvDtls.Range("B1").Value

Select Case AgtName
    Case "RecoveriesCorp"
        AgtName = "RecovCrp"
    Case "National Mercantile"
        AgtName = "National Merc"
End Select

wsSupSheet.Range("A" & lastrow & ":" & "C" & lastrow).Offset(1).Merge
wsSupSheet.Range("A" & lastrow & ":" & "C" & lastrow).Offset(1) = (AgtName & " " & InvNum)

TransCnt = wsTmpSh.Cells(Rows.Count, "A").End(xlUp).Row - 1 'Taken one off for the header.

rNum = 3
cNum = 2
clcnt = 1
clcnt2 = 1
nLoop = TransCnt / 16
TloopCnt = 16
cc = TransCnt
dd = TransCnt + 16
CommLoopCnt = 3
CommLoopCnt2 = 6

'''''''''''''''''''''''Main Loop'''''''''''''''''''''''

For Mloop = 1 To nLoop + 1
    
'''''''''''''''''''''''T Screen Loop'''''''''''''''''''

        For Tloop = 1 To TloopCnt
            wsSupSheet.Range("A" & lastrow).Offset(rNum, cNum) = "K" & wsTmpSh.Range("A" & clcnt + 1)
            wsSupSheet.Range("A" & lastrow).Offset(rNum, cNum + 1) = wsTmpSh.Range("B" & clcnt + 1)
            rNum = rNum + 1
         
            clcnt = clcnt + 1
        Next Tloop
        cc = cc - 16
        
        If TloopCnt > cc Then
            TloopCnt = cc
            
        End If
        
'''''''''''''''''''''''Commision Loop'''''''''''''''''''
        dd = cc
        rNum = rNum + 1
        'dd = dd - 16
        Debug.Print cc
        
        
        CommLoopCnt2 = 6
        
        
        For CommLoop = 1 To CommLoopCnt
            For CommLoop2 = 1 To CommLoopCnt2
                wsSupSheet.Range("A" & lastrow).Offset(rNum, cNum) = "N" & wsTmpSh.Range("A" & clcnt2 + 1)
                clcnt2 = clcnt2 + 1
                cNum = cNum + 1
              
            Next CommLoop2
                  'dd = dd - 2
                If CommLoop = 2 Then
                  CommLoopCnt2 = 4
                End If
                cNum = 2
                rNum = rNum + 1
               ' If cc < 16 Then
                   ' CommLoopCnt2 = CommLoopCnt2 + cc
               ' End If
           
       Next CommLoop
        
        
        rNum = rNum + 1
  
Next Mloop

End Sub
 
Wow, I have take out option explicit and it splits the data up amazingly.

Just a few questions if possible. The 1st and 3rd arrays are good to go and will paste perfectly in their portions of receipting.

2nd Array, I worked out how the information needs to be entered in excel so that when I copy and paste the data is matches up with the program.

Below is an image of what the 2nd array

1648901090672.png


This page has additonal info that is set and cells I would skip in excel, which represents when no data is being entered in a field.

Below is just a section of 16 transactions

Claim NumberAmountInc Comm
DP1303148405.5
KV1969096405.5
OX133183310013.76
WD127011519026.14
YF171851010013.76
PI128963140055
LS1778870608.26
EN1882707608.25
NA165551020027.5
ZQ1978656608.26
IC1308145405.5
RZ1600817405.5
AL1777416304.14
DP1181379608.26
KX1939472608.26
OV142102410013.76



and below is how I want the data to appear for the 2nd array


N1DP130314890p-5.503CommissionN1KV196909690p-5.503CommissionN1OX133183390p-13.763CommissionN1WD127011590p-26.143CommissionN1YF171851090p-13.763CommissionN1PI128963190p-55.003Commission
N1LS177887090p-8.263CommissionN1EN188270790p-8.253CommissionN1NA165551090p-27.503CommissionN13YF171851090p-8.263CommissionN1IC130814590p-5.503CommissionN1RZ160081790p-5.503Commission
N1AL177741690p-4.143CommissionN17WD127011590p-8.263CommissionN18YF171851090p-8.263CommissionN1OV142102490p-13.763Commission


I would then copy row 1 and paste it into the above form and the same for rows 2 and 3.

Below is what I would do if I was going to manually obtain the format I wanted in excel

1648902088585.png


You can ignore the colours, as this was only to help me keep track of the the blank cells and when a new transaction started (green).

With the title I only need it can be removed from the array as this will only be entered once on the new worksheet that is created with when the code is processed.

And, is it possible for each new start of the three arrays to be entered at the bottom of the 3rd array on the output?

Again, thank you for your help, that code is amazing and I have been going through it line by line to try to understand what is occuring. I am partly there, but will get there:)
 

Attachments

  • 1648902016379.png
    1648902016379.png
    9.5 KB · Views: 3
Upvote 0

Excel Facts

Highlight Duplicates
Home, Conditional Formatting, Highlight Cells, Duplicate records, OK to add pink formatting to any duplicates in selected range.
thank you so much, this will let me get a lot of receipting done today, and my report to management on Monday will be a lot better. I really appreciate your help, plus I am going to go through the code as it will be great to see what you wrote and how it works.
 
Upvote 0
collecting your data in arrays isn't that difficult, but once you know how to cut values out of an array, you can do everything.
To understand "application.index" with an array, see
VBA for smarties: Arrays and there "6. Working with Arrays".
You have excel-365, the new worksheetfunction.sequence can help you a lot for taking a part out of an array.
See some examples in oberon70
The examples have no added value, they just show how ik works.

VBA Code:
Sub testing()
     a = Range("TBL_Claims").ListObject.DataBodyRange.Value     'read the values of this table (size unknown)

     With Sheets("blad1")
          .UsedRange.ClearContents

     'take the 2nd, 5th, 8th,11th and 14th claimnumber
          myrows = WorksheetFunction.Sequence(5, , 2, 3)        'an array of 5 rows and 1 column starting with 2 and incrementing with 3
          With .Range("A1").Resize(UBound(myrows), UBound(myrows, 2))
               .Value = myrows                                  'just to show you that sequence
               .Offset(, 2).Value = Application.Index(a, myrows, 1)
          End With

     'on previous sheet, those alternating columns with values and backgroundcolors, join those columns with values together
          a1 = Sheets("blad2").Range("AI1:CC3").Value
          mycolumns = WorksheetFunction.Sequence(1, 16, 1, 2)   'an array of 1 row and 16 column, starting with 1 and step 2 = 1st, 3rd, 5th ....
          With .Range("A10").Resize(1, UBound(mycolumns))
               .Value = mycolumns                               'show sequence
               .Offset(2).Value = Application.Index(a1, 2, mycolumns)     '=AI2:CC2 without the empty columns
          End With


        'the same as previous but now take row 1,41 and 81
          a2 = Sheets("blad2").Range("AI1:CC100").Value
          myrows = WorksheetFunction.Sequence(3, , 1, 40)
          mycolumns = WorksheetFunction.Sequence(1, 16, 1, 2)   'an array of 1 row and 16 column, starting with 1 and step 2 = 1st, 3rd, 5th ....
          With .Range("A20")
               .Resize(1, UBound(mycolumns)) = mycolumns
               .Offset(2).Resize(UBound(myrows)).Value = myrows
               .Offset(6).Resize(UBound(myrows), UBound(mycolumns)).Value = Application.Index(a2, myrows, mycolumns)
              
          End With

     End With
End Sub
 
Upvote 0
no, thank you, I will defiantly go through them. I am just going to receipt this afternoon, get my work in a more up to date state and then next weekend and when am on leave for easter, it will be reading the above, plus some online courses I have downloaded.

Just one question, and this is my fault, as I was going off memory, because I couldn't test due to system maintenance on the work program. The 3rd array, how do I go about putting a cell the below.

The current output

1648961014614.png


but want

1648961109995.png



VBA Code:
With .Offset(23, 2)
                    For i3 = 1 To 3
                        .Offset((i3 - 1) * 13).Resize(12, 2).Value = Application.Index(O3, WorksheetFunction.Sequence(12, 1, (i3 - 1) * 12 + 1), Array(1, 2))
                    Next
               End With

I will keep stepping through the code to see if I can figure it out;).
 
Upvote 0
you can resize that array to have 3 columns and leave the 2nd column empty
ReDim O3(1 To 3 * iSet, 1 To 3) '-> extra column

then write to that 3rd elemnt
O3((i1 - 1) * 2 + 1, 1) = -a(ptr, 2)
O3((i1 - 1) * 2 + 1, 3) = "payment " & a(ptr, 1)
O3(i1 * 2, 1) = a(ptr, 3)
O3(i1 * 2, 3) = "Commission"

And finally copy 3 columns
With .Offset(, 5)
For i3 = 1 To 3
.Offset((i3 - 1) * 13).Resize(12, 3).Value = Application.Index(O3, WorksheetFunction.Sequence(12, 1, (i3 - 1) * 12 + 1), Array(1, 2,3))
Next
End With

or being lazy, don't add that 3rd column, but copy the 2nd column twice and delete the 1st of both
With .Offset(, 5)
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
 
Upvote 0
Thanks, I will try that out and then I have a few more questions, not major as what you have provided is working alike a charm.
 
Upvote 0
I must have gotten something wrong -

VBA Code:
'Option Explicit
Sub DoubleLoop()
     Dim i0, i, i1, s, iSet, iTotal, a, O1(), O2(), O3(), sh, wb

     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 3)

     '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) = "Insured Loss " & 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 + 40 * i, "AA")
            Set wb = ThisWorkbook
             With wb.Sheets("SpeedReceipt").Cells(1 + 61 * i, "C")
             Debug.Print sh.Cells(1 + 40 * i, "c").Address
               .Value = wb.Sheets("Invoice Details").Range("B3").Value & " " & wb.Sheets("Invoice Details").Range("B1")                    ' a title ?

               .Offset(2, 2).Resize(UBound(O1), UBound(O1, 2)).Value = O1     '1st array = claimcounter & amount
               .Offset(2, -2).Value = "Press Me"
             
               With .Offset(23, 2)
                    For i3 = 1 To 3
                        .Offset((i3 - 1) * 13).Resize(12, 3).Value = Application.Index(O3, WorksheetFunction.Sequence(12, 1, (i3 - 1) * 12 + 1), Array(1, 2, 3))
                    Next
               End With

               With .Offset(19, 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(59).Resize(, 60).Borders(xlEdgeBottom)
                    .LineStyle = xlDouble
                    .Color = -16776961
                    .TintAndShade = 0
                    .Weight = xlThick
               End With

          End With
     Next

     'With wb.Sheets("SpeedReceipt").UsedRange.EntireColumn
          '.ColumnWidth = 2
        '  .AutoFit                                              'adjust columnwidth
     'End With
     'wb.Sheets("SpeedReceipt").Columns("B:Z").EntireColumn.Hidden = True

End Sub

As it is still the same.

1648965839897.png
 
Upvote 0
Okay, found where my mistake was, it is now working

I didn't make the below change

VBA Code:
O3((i1 - 1) * 2 + 1, [B]3[/B]) = "payment " & a(ptr, 1)
 
Upvote 0
okay, I just receipted 64 transactions in under 5 minutes.... whoohooo.

Below is the current look of the output using your code you wrote

SpeedReceipting (002).xlsm
ABCDEFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKALAMANAOAPAQARASATAUAVAWAXAYAZ
1Press MeWayne Tech WT-9094T
2
3Press MeKDP130314840
4KKV196909640
5Batch #KOX1331833100
6KWD1270115190
7KYF1718510100
8KPI1289631400
9KLS177887060
10KEN188270760
11KNA1655510200
12KZQ197865660
13KIC130814540
14KRZ160081740
15KAL177741630
16KDP118137960
17KEN193947260
18KDP20957340
19
20Press MeN1DP130314890p-103CommissionN1KV196909690p-103CommissionN1OX133183390p-253CommissionN1WD127011590p-47.53CommissionN1YF171851090p-253CommissionN1PI128963190p-1003Commission
21Press MeN1LS177887090p-153CommissionN1EN188270790p-153CommissionN1NA165551090p-503CommissionN1ZQ197865690p-153CommissionN1IC130814590p-103CommissionN1RZ160081790p-103Commission
22Press MeN1AL177741690p-7.53CommissionN1DP118137990p-153CommissionN1EN193947290p-153CommissionN1DP20957390p-103Commission
23
24Press Me-40Insured Loss DP1303148
2510Commission
26-40Insured Loss KV1969096
2710Commission
28-100Insured Loss OX1331833
2925Commission
30-190Insured Loss WD1270115
3147.5Commission
32-100Insured Loss YF1718510
SpeedReceipt


The next and likely final step for a while would be able to click on the cell that says "Press Me" and then an automatic copy would occur of the area I want. Example Row 1 would copy "C1:V1"
or E3:E18 and so forth. Basic, I want to copy each section that corresponds to the cell with press me.

Would you recommend offsetting from he activecell? when I click on press me? , then how would I go about selecting the area I want?
 
Upvote 0

Forum statistics

Threads
1,213,550
Messages
6,114,265
Members
448,558
Latest member
aivin

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