Loop taking a long time and then only working part of the way

Oberon70

Oberon70

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

I have written the below code

VBA Code: 
Option Explicit

Dim x As Double
Dim y As Double
Dim wb As Workbook
Dim wsTransc As Worksheet
Dim wsListCl As Worksheet
Dim LastRowTransc As Double

Sub Report1()

Dim NumStatemetns As Double
Dim i As Double
Dim LastRowLClms As Double
Dim StNum As String

Set wb = ThisWorkbook
Set wsTransc = wb.Sheets("Table2")
Set wsListCl = wb.Sheets("List of Claims")

NumStatemetns = 17

wsTransc.Activate

LastRowTransc = (FindLast(xlFindLastRow))

wsListCl.Activate

LastRowLClms = (FindLast(xlFindLastRow))

Debug.Print LastRowTransc

For i = 3 To LastRowLClms
    Debug.Print Cells(i, 1).Value
    Cells(i, 1).Select
   
  For y = 2 To LastRowTransc
    StNum = wsTransc.Cells(y, 2).Value
    wsListCl.Cells(i, 10).Select
    wsListCl.Cells(i, 11).Select
    If wsListCl.Cells(i, 1).Value = wsTransc.Cells(y, 1) Then
    Select Case StNum
     Case 6879
       wsListCl.Cells(i, 2) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 3) = wsTransc.Cells(y, 4).Value
     Case 6880
       wsListCl.Cells(i, 4) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 5) = wsTransc.Cells(y, 4).Value
      Case 6881
       wsListCl.Cells(i, 6) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 7) = wsTransc.Cells(y, 4).Value
     Case 6993
       wsListCl.Cells(i, 8) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 9) = wsTransc.Cells(y, 4).Value
     Case 6995
       wsListCl.Cells(i, 10) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 11) = wsTransc.Cells(y, 4).Value
     Case 6996
       wsListCl.Cells(i, 12) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 13) = wsTransc.Cells(y, 4).Value
     Case 6997
       wsListCl.Cells(i, 14) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 15) = wsTransc.Cells(y, 4).Value
     Case 7101
       wsListCl.Cells(i, 16) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 17) = wsTransc.Cells(y, 4).Value
     Case 7102
       wsListCl.Cells(i, 18) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 19) = wsTransc.Cells(y, 4).Value
     Case 7103
       wsListCl.Cells(i, 20) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 21) = wsTransc.Cells(y, 4).Value
     Case 7209
       wsListCl.Cells(i, 22) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 23) = wsTransc.Cells(y, 4).Value
     Case 7210
       wsListCl.Cells(i, 24) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 25) = wsTransc.Cells(y, 4).Value
     Case 7211
       wsListCl.Cells(i, 26) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 27) = wsTransc.Cells(y, 4).Value
     Case 7323
       wsListCl.Cells(i, 28) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 29) = wsTransc.Cells(y, 4).Value
     Case 7433
       wsListCl.Cells(i, 30) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 31) = wsTransc.Cells(y, 4).Value
     Case 7435
       wsListCl.Cells(i, 32) = wsTransc.Cells(y, 3).Value
       wsListCl.Cells(i, 33) = wsTransc.Cells(y, 4).Value
    End Select
    End If
   Next y
Next i

LastRowTransc = 0

End Sub

Which worked great on the below test spreadsheet.

https://1drv.ms/x/s!AtcG2TZ_Kn5yovoIPSGrK_xy5ISA6w

but when I applied it to a statement that had 8000 entries it takes around 15 minutes, then for some reason from transaction 34 none of the data is moved into the rows on sheet List of Claims.

If there a way for me to enter step by step in vba when a value equal to say the reference number I now where the problem starts? or is there a much better way to accomplish what I am wanting to do?

Let me know if I need to provide anything. I will then log into my home computer as I am currently on my work laptop.
 

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
Sort by date Sort by votes
Interaction with spreadsheet takes really much time for large data, so try to minimize that.
One way is to store sheet data in an array, and do some data processing without touching sheet, and then write back entire result array back to sheet in one time.
For example:
VBA Code: 
Dim InputArrayA()
Dim InputArrayB()
Dim InputArrayC()
Dim StNum()
Dim OutputArray()

'Store sheet values in array
InputArrayA = wsListCl.Range(wsListCl.Cells(3, 1), wsListCl.Cells(LastRowLClms, 1)).Value
InputArrayB = wsTransc.Range(wsTransc.Cells(2, 1), wsTransc.Cells(LastRowTransc, 1)).Value
InputArrayC = wsTransc.Range(wsTransc.Cells(2, 3), wsTransc.Cells(LastRowTransc, 4)).Value
StNum = wsTransc.Range(wsTransc.Cells(2, 2), wsTransc.Cells(LastRowTransc, 2)).Value
ReDim OutputArray(1 To LastRowLClms-2, 1 To 32)

'Some processing
For i = 3 To LastRowLClms
   For y = 2 To LastRowTransc
      If InputArrayA(i-2, 1) = InputArrayB(y-1, 1) Then
          Select Case StNum(y-1, 1)
              Case 6879
                  OutputArray(i-2, 1) = InputArrayC(y-1, 1)
                  OutputArray(i-2, 2) = InputArrayC(y-1, 2)
              Case 6880
                  OutputArray(i-2, 3) = InputArrayC(y-1, 1)
                  OutputArray(i-2, 4) = InputArrayC(y-1, 2)
              'and so on...
          End Select
      End If
   Next y
Next i

'Write processed array to sheet
wsListCl.Range(wsListCl.Cells(3, 3), wsListCl.Cells(LastRowLClms, 32)).Value = OutputArray

I hope my code is understandable for you to continue?
Please mind the index. The array from and to sheet is a 2D array with index starts from 1.
 
Upvote 0
Perhaps a bit easier to follow:

VBA Code: 
Option Explicit
'
    Dim LastRowTransc   As Double
    Dim x               As Double
    Dim y               As Double
    Dim wb              As Workbook
    Dim wsTransc        As Worksheet
    Dim wsListCl        As Worksheet

Sub Report1()
'
    Dim i               As Double
    Dim LastRowLClms    As Double
    Dim NumStatemetns   As Double
    Dim StNum           As String
'
    Set wb = ThisWorkbook
'
    Set wsListCl = wb.Sheets("List of Claims")
    Set wsTransc = wb.Sheets("Table2")
'
    NumStatemetns = 17
'
    wsTransc.Activate
    LastRowTransc = (FindLast(xlFindLastRow))
'
    wsListCl.Activate
    LastRowLClms = (FindLast(xlFindLastRow))
'
    Dim ListClArray As Variant
    Dim TranscArray As Variant
'
    ListClArray = wsListCl.Range("A1:AG" & LastRowLClms)
    TranscArray = wsTransc.Range("A1:D" & LastRowTransc)
'
    For i = 3 To LastRowLClms
        For y = 2 To LastRowTransc
            StNum = TranscArray(y, 2)
'
            If ListClArray(i, 1) = TranscArray(y, 1) Then
                Select Case StNum
                    Case 6879
                        ListClArray(i, 2) = TranscArray(y, 3)
                        ListClArray(i, 3) = TranscArray(y, 4)
                    Case 6880
                        ListClArray(i, 4) = TranscArray(y, 3)
                        ListClArray(i, 5) = TranscArray(y, 4)
                    Case 6881
                        ListClArray(i, 6) = TranscArray(y, 3)
                        ListClArray(i, 7) = TranscArray(y, 4)
                    Case 6993
                        ListClArray(i, 8) = TranscArray(y, 3)
                        ListClArray(i, 9) = TranscArray(y, 4)
                    Case 6995
                        ListClArray(i, 10) = TranscArray(y, 3)
                        ListClArray(i, 11) = TranscArray(y, 4)
                    Case 6996
                        ListClArray(i, 12) = TranscArray(y, 3)
                        ListClArray(i, 13) = TranscArray(y, 4)
                    Case 6997
                        ListClArray(i, 14) = TranscArray(y, 3)
                        ListClArray(i, 15) = TranscArray(y, 4)
                    Case 7101
                        ListClArray(i, 16) = TranscArray(y, 3)
                        ListClArray(i, 17) = TranscArray(y, 4)
                    Case 7102
                        ListClArray(i, 18) = TranscArray(y, 3)
                        ListClArray(i, 19) = TranscArray(y, 4)
                    Case 7103
                        ListClArray(i, 20) = TranscArray(y, 3)
                        ListClArray(i, 21) = TranscArray(y, 4)
                    Case 7209
                        ListClArray(i, 22) = TranscArray(y, 3)
                        ListClArray(i, 23) = TranscArray(y, 4)
                    Case 7210
                        ListClArray(i, 24) = TranscArray(y, 3)
                        ListClArray(i, 25) = TranscArray(y, 4)
                    Case 7211
                        ListClArray(i, 26) = TranscArray(y, 3)
                        ListClArray(i, 27) = TranscArray(y, 4)
                    Case 7323
                        ListClArray(i, 28) = TranscArray(y, 3)
                        ListClArray(i, 29) = TranscArray(y, 4)
                    Case 7433
                        ListClArray(i, 30) = TranscArray(y, 3)
                        ListClArray(i, 31) = TranscArray(y, 4)
                    Case 7435
                        ListClArray(i, 32) = TranscArray(y, 3)
                        ListClArray(i, 33) = TranscArray(y, 4)
                End Select
            End If
        Next y
    Next i
'
    wsListCl.Range("A1:AG" & LastRowLClms) = ListClArray
    wsTransc.Range("A1:D" & LastRowTransc) = TranscArray
'
    LastRowTransc = 0
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

K
  • Solved
Code not working
Replies
1
Views
339
KasperC
K
W
  • Question
Error Loop Without Do
Replies
5
Views
325
Legacy 143009
L
A
  • Solved
Calendar form cancel button passing data to worksheet
Replies
7
Views
395
AndyEd
A
T
  • Solved
Run Time 13 Mismatch Error
Replies
8
Views
508
Alex Blakenburg
A
A
  • Solved
Calendar issue
Replies
1
Views
1K
AndyEd
A

Forum statistics

Threads
1,214,840
Messages
6,121,895
Members
449,058
Latest member
Guy Boot

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