Excel VBA Manipulating data in array is taking long time

kashif.special2005

Active Member
Joined
Oct 26, 2009
Messages
443
I All,

I have two sheets 1st is called "AADB" and second is called "MDT Access"


AADB have around 200000 rows and 20 columns data, and MDT Access have around 2000 rows and 5 columns data


I want to updating the sheet "Result" with data on below conditions.


I am applying loop on each row in the sheet AADB and in the column 2, if that loop cell column 2 value is available in the sheet MDT Access column 1 and if loop cell column 13 value from the sheet AADB is available in the sheet MDT Access column 4 then update the array with the loop row data of all columns of the sheet AADB.

Note:- FundID are duplicates in both the sheet.

FundID is Column 2 in The sheet AADB, and FundID is column 2 in MDT Access.

Code:
Sub QCCombineArrays()
    Dim varAADBinfo As Variant, MDTPIAccessInfo As Variant, varCombineArray As Variant
    Dim LastRow As Long, intdisplayrow As Long, Row As Long, Y As Long
    
    LastRow = Sheets("AADB").Cells(Rows.Count, "A").End(xlUp).Row
    varAADBinfo = Sheets("AADB").Range("A3:S" & LastRow).Value2
    
    LastRow = Sheets("MDT Access").Cells(Rows.Count, "A").End(xlUp).Row
    MDTPIAccessInfo = Sheets("MDT Access").Range("A3:E" & LastRow).Value2
    
    ReDim varCombineArray(UBound(varAADBinfo, 1), UBound(varAADBinfo, 2)) As Variant

    For Row = 1 To UBound(MDTPIAccessInfo, 1)
    
        For Y = 1 To UBound(varAADBinfo, 1)
           
            'varAADBinfo(, 2)=FundID
            'MDTPIAccessInfo(, 1)=FundID
            'varAADBinfo(, 14)=Trans_Date
            'MDTPIAccessInfo(, 3)=TransDate
            If varAADBinfo(Y, 2) = MDTPIAccessInfo(Row, 1) And varAADBinfo(Y, 14) = MDTPIAccessInfo(Row, 3) Then
            
                    'AADB info
                    For Column = 1 To UBound(varAADBinfo, 2)
                        varCombineArray(intdisplayrow, Column) = varAADBinfo(Y, Column)
                    Next Column
                    
                    'QCer info from PI Database
                    'MDTPIAccessInfo(Row, 4)=QCPerson
                    varCombineArray(intdisplayrow, 11) = MDTPIAccessInfo(Row, 4)
                    intdisplayrow = intdisplayrow + 1
            End If
        Next Y
    Next Row
    ActiveSheet.Range(Cells(14, 2), Cells(UBound(varCombineArray, 1) + 14, UBound(varCombineArray, 2) + 2)) = varCombineArray
    
End Sub

Please kindly request to all excel experts please help me on this problem.



Thanks in advance.



Thanks
Kashif
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Untested, but how about
Code:
Sub kashifspecial2005()
   Dim MDTary As Variant, AADBary As Variant, Outary As Variant
   Dim r As Long, c As Long, rr As Long
   
   With Sheets("MDT")
      MDTary = .Range("A3", .Range("A" & Rows.Count).End(xlUp).Offset(, 4)).Value2
   End With
   With Sheets("AADB")
      AADBary = .Range("A3", .Range("A" & Rows.Count).End(xlUp).Offset(, 14)).Value2
   End With
   ReDim Outary(1 To UBound(AADBary), 1 To UBound(AADBary, 2))
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(MDTary)
         .Item(MDTary(r, 1) & "|" & MDTary(r, 3)) = Empty
      Next r
      For r = 1 To UBound(AADBary)
         If .Exists(AADBary(r, 2) & "|" & AADBary(r, 14)) Then
            rr = rr + 1
            For c = 1 To UBound(AADBary, 2)
               Outary(rr, c) = AADBary(r, c)
            Next c
         End If
      Next r
   End With
   Range("B14").Resize(rr, UBound(AADBary, 2)).Value2 = Outary
End Sub
 
Upvote 0
Hi Fluff,

Thank you so much for reply, yes I have tested the code and it producing the same result as my code.
However I have one concern here you are generating a unique key in the dictionary object, and if there is duplicate combination of FundId and the date then it will replace the first key, but this not my code is doing if there is duplicate combination again then it will again add those details in the array.


Can it is possible in your code?


Thanks once again for your reply.



Thanks
Kashif
 
Upvote 0
Duplicates shouldn't be a problem, because it will copy each row from the AADB sheet if cols 2/14 match cols 1/3 on the MDT sheet.
 
Upvote 0
Hi Fluff,

Thanks for reply, I am saying that there may be duplicate values in the sheet MDT for column 1 and 3.

Let me explain


For example suppose I have data in AADB like below

FundID Date
1 1/05/2019
1 1/05/2019
2 2/04/2019

and suppose I have data in MDT like below

FundID Date
1 1/05/2019
1 1/05/2019
2 2/04/2019
4 5/02/2019

The the output should be like below.

FundID Date
1 1/05/2019
1 1/05/2019
1 1/05/2019
1 1/05/2019
2 2/04/2019

Because you can notice that FundID 1 and Date 1/05/2019 are repeating in the MDT sheet.

However your code generating the following results

FundID Date
1 1/05/2019
1 1/05/2019
2 2/04/2019

Thanks
Kashif
 
Upvote 0
Ok, how about
Code:
Sub kashifspecial2005()
   Dim MDTary As Variant, AADBary As Variant, Outary As Variant
   Dim r As Long, c As Long, rr As Long
   
   With Sheets("MDT")
      MDTary = .Range("A3", .Range("A" & Rows.Count).End(xlUp).Offset(, 4)).Value2
   End With
   With Sheets("AADB")
      AADBary = .Range("A3", .Range("A" & Rows.Count).End(xlUp).Offset(, 14)).Value2
   End With
   ReDim Outary(1 To UBound(AADBary) * UBound(MDTary), 1 To UBound(AADBary, 2))
   With CreateObject("scripting.dictionary")
      For r = 1 To UBound(MDTary)
         .Item(MDTary(r, 1) & "|" & MDTary(r, 3)) = .Item(MDTary(r, 1) & "|" & MDTary(r, 3)) + 1
      Next r
      For r = 1 To UBound(AADBary)
         If .Exists(AADBary(r, 2) & "|" & AADBary(r, 14)) Then
            For i = 1 To .Item(AADBary(r, 2) & "|" & AADBary(r, 14))
               rr = rr + 1
               For c = 1 To UBound(AADBary, 2)
                  Outary(rr, c) = AADBary(r, c)
               Next c
            Next i
         End If
      Next r
   End With
   Range("B14").Resize(rr, UBound(AADBary, 2)).Value2 = Outary
End Sub
 
Upvote 0
You're welcome & thanks for the feedback
 
Upvote 0

Forum statistics

Threads
1,213,552
Messages
6,114,278
Members
448,560
Latest member
Torchwood72

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