MobileMobile | Continue

Excel Bar

Excel Bar

Your excel questions will be responsed by our excel experts within 24hrs.Our service is free.

 Forgot Pass?
 Register Now
Find
Hot Search: Vlookup Match VBA
View: 336|Reply: 4

Store multiple arrays in one array [SOLVED]

[Copy link]

72

Topics

721

Posts

1666

Integral

King

Rank: 6Rank: 6

Integral
1666
Post on 2-12-2017 01:27:04 | All posts |Read mode
Hello everyone
I have the following code that posts results for each row (arrRes array) and this slows down the process with large data
So I need a way to store each arrRes array in one big array to put the results in one shot
Sub Test()
    Dim arrNum()    As Variant
    Dim arrVal()    As Variant
    Dim arrRes()    As Variant
    Dim k           As Long
    Dim i           As Long
    Dim itm         As Variant
    Dim c           As Long
    Application.ScreenUpdating = False
        With ActiveSheet
            For k = 5 To .Cells(Rows.Count, 1).End(xlUp).Row Step 3
            c = 0: i = 0
            arrNum = .Range(C  k  :G  k).Value
            arrVal = .Range(K  k  :AY  k).Value
            arrRes = .Range(BQ  k  :BU  k).Value
        
            For Each itm In arrVal
                c = c + 1
                If Not IsError(Application.Match(itm, arrNum, 0)) Then
                    i = i + 1
                    arrRes(1, i) = c
                End If
            Next itm
            
            .Range(BQ  k  :BU  k).Value = arrRes
            Erase arrNum: Erase arrVal: Erase arrRes
            Next k
        End With
    Application.ScreenUpdating = True
End SubThanks advanced for help













Reply

Props Report

11

Topics

662

Posts

1497

Integral

King

Rank: 6Rank: 6

Integral
1497
Post on 2-12-2017 02:28:15 | All posts



Try this...

Sub
Test()
   
Dim
arrNum     
As

Variant
   
Dim
arrVal     
As

Variant
   
Dim
arrRes     
As

Variant
   
Dim
k         
As

Long
   
Dim
i         
As

Long
   
Dim
c         
As

Long
   
Dim
lr         
As

Long
   
   
With
ActiveSheet
        lr = .Range(A  Rows.Count).End(xlUp).Row
        arrNum = .Range(C5:G  lr).Value
        arrVal = .Range(K5:AY  lr).Value
        arrRes = .Range(BQ5:BU  lr).Value
        
        
For
k = 1
To

UBound
(arrNum, 1)
Step
3
            
With
CreateObject(Scripting.Dictionary)
               
For
c = 1
To

UBound
(arrNum, 2)
                    .Item(arrNum(k, c)) = 1
               
Next
c
                i = 0
               
For
c = 1
To

UBound
(arrVal, 2)
                    
If
.Exists(arrVal(k, c))
Then
                        i = i + 1
                        arrRes(k, i) = arrVal(k, c)
                    
End

If
               
Next
c
            
End

With
        
Next
k
        
        .Range(BQ5:BU  lr).Value = arrRes
        Erase arrNum: Erase arrVal: Erase arrRes
   
End

With
   
End

Sub












Reply Support Opposition

Props Report

72

Topics

721

Posts

1666

Integral

King

Rank: 6Rank: 6

Integral
1666
 Author| Post on 2-12-2017 03:13:30 | All posts



Thanks a lot Mr. AlphaFrog
It seems that the results are different. Please have a look at this sample








  • Sample.xlsm
    (218.9 KB, 11 views)
    Download













  • Reply Support Opposition

    Props Report

    11

    Topics

    662

    Posts

    1497

    Integral

    King

    Rank: 6Rank: 6

    Integral
    1497
    Post on 2-12-2017 04:28:44 | All posts




    Sub
    AlphaFrog()
       
    Dim
    arrNum     
    As

    Variant
       
    Dim
    arrVal     
    As

    Variant
       
    Dim
    arrRes     
    As

    Variant
       
    Dim
    k         
    As

    Long
       
    Dim
    i         
    As

    Long
       
    Dim
    c         
    As

    Long
       
    Dim
    lr         
    As

    Long
       
       
    With
    ActiveSheet
            lr = .Range(C  Rows.Count).End(xlUp).Row
            arrNum = .Range(C5:G  lr).Value
            arrVal = .Range(K5:AY  lr).Value
            arrRes = .Range(BQ5:BU  lr).Value
            
            
    For
    k = 1
    To

    UBound
    (arrNum, 1)
    Step
    3
                
    With
    CreateObject(Scripting.Dictionary)
                   
    For
    c = 1
    To

    UBound
    (arrNum, 2)
                        .Item(arrNum(k, c)) = 1
                   
    Next
    c
                    i = 0
                   
    For
    c = 1
    To

    UBound
    (arrVal, 2)
                        
    If
    .Exists(arrVal(k, c))
    Then
                            i = i + 1
                            arrRes(k, i) =
    [color=]c

                        
    End

    If
                   
    Next
    c
                
    End

    With
            
    Next
    k
            
            .Range(BQ5:BU  lr).Value = arrRes
            Erase arrNum: Erase arrVal: Erase arrRes
       
    End

    With

    End

    Sub









    Reply Support Opposition

    Props Report

    72

    Topics

    721

    Posts

    1666

    Integral

    King

    Rank: 6Rank: 6

    Integral
    1666
     Author| Post on 2-12-2017 06:03:10 | All posts



    That's amazing and awesome
    Thank you very much for this perfect solution
    Reply Support Opposition

    Props Report

    Points policy of this forum

    Archiver|Mobile|Small dark house|Contact us|Excel Bar

    GMT-5, 11-19-2017 16:19 , Processed in 0.137421 second(s), 20 queries .

    Powered by Discuz! X3

    © 2001-2013 Comsenz Inc.

    !fastreply! Top !return_list!