Arrays read from, write to

**Thompyt** · 12-16-2022, 12:34 PM

I am attempting to speed up the following code. I figured placing it in "memory" and updating it in "memory" is quicker than reading it from a sheet, then writing to the sheet. Then dump the desired information to the sheet at the end. Is d1 not an array in the second code?

This code works:

Code:

Sub RoleS()

    strTab = "PC22V2"
       
    Set WkSht = Worksheets(strTab)
    Set WkSht2 = Worksheets("UniqueRefer")
    Set WkSht3 = Worksheets("Acronyms")


    Set Rng = WkSht.UsedRange
    Set Rng2 = WkSht2.UsedRange
    Set Rng3 = WkSht3.UsedRange
    
    d1 = Rng.Value
    d2 = Rng2.Value
    d3 = Rng3.Value
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    RCnt = Range("A:Z").SpecialCells(xlCellTypeLastCell).Row   'Cells(Rows.Count, 1).End(xlUp)
    y = 1
    x = 1
    z = 1
   
    Worksheets(strTab).Range("N2:P" & RCnt).ClearContents


    For y = 2 To UBound(d2)
        For x = 2 To UBound(d1)
            If d2(y, 1) = d1(x, 1) Then Worksheets(strTab).Cells(x, 2) = d2(y, 2)                                                   ' Unit
            If d2(y, 1) = d1(x, 3) Then Worksheets(strTab).Cells(x, 4) = d2(y, 2) & "-"                                             ' Paragraph
            If d2(y, 1) = d1(x, 5) Then Worksheets(strTab).Cells(x, 6) = d2(y, 2) & "-"                                             ' Count and Roles
            If d2(y, 6) = d1(x, 9) Then Worksheets(strTab).Cells(x, 8) = d2(y, 5) & Worksheets(strTab).Cells(x, 13) & "-"           ' Equipment
                For z = 2 To UBound(d3)
                    If d1(x, 3) = d3(z, 1) Then Worksheets(strTab).Cells(x, 4) = d3(z, 2) & "-"                                     ' roles
                    If d1(x, 5) = d3(z, 1) Then Worksheets(strTab).Cells(x, 6) = d3(z, 2) & Worksheets(strTab).Cells(x, 13) & "-"   ' Count of roles
                    If d1(x, 9) = d3(z, 6) Then Worksheets(strTab).Cells(x, 8) = d3(z, 5) & "-"
                Next z
            If d1(x, 1) = d1(x, 3) Then Worksheets(strTab).Cells(x, 4) = ""
            If d1(x, 3) = d1(x, 5) Then Worksheets(strTab).Cells(x, 4) = ""
                If Worksheets(strTab).Cells(x, 12) = "" Then
                    Worksheets(strTab).Cells(x, 14) = Worksheets(strTab).Cells(x, 8) & Worksheets(strTab).Cells(x, 6) & Worksheets(strTab).Cells(x, 4) & Worksheets(strTab).Cells(x, 2)
                Else
                    Worksheets(strTab).Cells(x, 14) = Worksheets(strTab).Cells(x, 12) & Worksheets(strTab).Cells(x, 6) & Worksheets(strTab).Cells(x, 8) & Worksheets(strTab).Cells(x, 4) & Worksheets(strTab).Cells(x, 2)
                End If
                    Worksheets(strTab).Cells(x, 15) = Len(Worksheets(strTab).Cells(x, 14))

                    If Len(Worksheets(strTab).Cells(x, 14)) > 30 Then
                        Worksheets(strTab).Cells(x, 14).Interior.ColorIndex = 3
                        Worksheets(strTab).Cells(x, 16) = Len(Worksheets(strTab).Cells(x, 14)) - 30 & " Over"
                    Else
                        Worksheets(strTab).Cells(x, 14).Interior.ColorIndex = -4142
                    End If
                        If Worksheets(strTab).Cells(x, 13) = "" Then Worksheets(strTab).Cells(x, 17) = 1
                        If Worksheets(strTab).Cells(x, 13) <> "" Then Worksheets(strTab).Cells(x, 17) = Worksheets(strTab).Cells(x, 13)
         Next x
    Next y
        
    Sheets(strTab).Range("A1:O1").EntireColumn.AutoFit
        
    Call DelSht
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
  
End Sub

This is supposed to be the same with the d1(x, 14) replacing Worksheet(StrTab).Cells(x, 14). Here you get an empty value for any d1 items:

Code:

Sub RoleS()

    strTab = "PC22V2"
       
    Set WkSht = Worksheets(strTab)
    Set WkSht2 = Worksheets("UniqueRefer")
    Set WkSht3 = Worksheets("Acronyms")

    Set Rng = WkSht.UsedRange
    Set Rng2 = WkSht2.UsedRange
    Set Rng3 = WkSht3.UsedRange
    
    d1 = Rng.Value
    d2 = Rng2.Value
    d3 = Rng3.Value
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False

    RCnt = Range("A:Z").SpecialCells(xlCellTypeLastCell).Row   'Cells(Rows.Count, 1).End(xlUp)
    ReDim d1(RCnt, 26)
    y = 1
    x = 1
    z = 1
 
    ReDim d1(RCnt, 26)
 
    For y = 2 To UBound(d2)
        For x = 2 To UBound(d1)
           If d2(y, 1) = d1(x, 1) Then d1(x, 18) = d2(y, 2)
           If d2(y, 1) = d1(x, 3) Then d1(x, 19) = d2(y, 2) & "-"
           If d2(y, 1) = d1(x, 5) Then d1(x, 20) = d2(y, 2) & "-"
           If d2(y, 1) = d1(x, 9) Then d1(x, 21) = d2(y, 2) & d2(y, 13) & "-"
              For z = 2 To UBound(d3)
                    If d1(x, 3) = d3(z, 1) Then d1(x, 19) = d3(z, 2) & "-"
                    If d1(x, 5) = d3(z, 1) Then d1(x, 20) = d3(z, 2) & d2(y, 13) & "-"
                    If d1(x, 9) = d3(z, 6) Then d1(x, 21) = d3(z, 5) & "-"
              Next z
            If d1(x, 1) = d1(x, 3) Then d1(x, 4) = ""
            If d1(x, 3) = d1(x, 5) Then d1(x, 4) = ""
                If d1(x, 12) = "" Then
                    d1(x, 14) = d1(x, 8) & d1(x, 6) & d1(x, 4) & d1(x, 2)
                Else
                    d1(x, 14) = d1(x, 12) & d1(x, 6) & d1(x, 8) & d1(x, 4) & d1(x, 2)
                End If
                    d1(x, 15) = Len(d1(x, 14))

Debug.Print "Roles: " & d1(x, 14), , "Out: " & Worksheets(strTab).Cells(x, 14), , "Length: " & d1(x, 15)

                    If Len(d1(x, 14)) > 30 Then
                        d1(x, 14).Interior.ColorIndex = 3
                        d1(x, 16) = Len(d1(x, 14)) - 30 & " Over"
                    End If
                       If d1(x, 13) = "" Then d1(x, 17) = 1
                       If d1(x, 13) <> "" Then d1(x, 17) = d1(x, 13)
        Next x
   Next y
          
    Sheets(strTab).Range("A1:O1").EntireColumn.AutoFit
        
    Call DelSht
 
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
  
End Sub

**Micron** · 12-16-2022, 02:13 PM

Not sure I understand what you want. It looks to me like you're working only with the arrays, checking/modifying elements but never applying to a range in the second code.
This makes cell x,4 = an array element
Then Worksheets(strTab).Cells(x, 4) = d3(z, 2) & "-"

This might make range/cell x,19 = to a d3 array element except for the fact that d3 is declared as a range value, not a range or a cell.
Then d1(x, 19) = d3(z, 2) & "-"

HTH

Come to think of it, now I don't see how it works in the first code since the declarations are the same.

**Thompyt** · 12-16-2022, 05:23 PM

Micron,
I've got it working with this code.

Code:

Sub RoleS()

    strTab = "PC22V2"
       
    Set WkSht = Worksheets(strTab)
    Set WkSht2 = Worksheets("UniqueRefer")
    Set WkSht3 = Worksheets("Acronyms")


    Set Rng = WkSht.UsedRange
    Set Rng2 = WkSht2.UsedRange
    Set Rng3 = WkSht3.UsedRange
    
    d1 = Rng.Value
    d2 = Rng2.Value
    d3 = Rng3.Value


    y = 1
    x = 1
    z = 1
    
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False


    RCnt = Range("A1:Z2").SpecialCells(xlCellTypeLastCell).Row
    ReDim ArrV(RCnt, 26)
    ArrV = Range("A1:Z" & RCnt).Value
    
    Range("J2:M" & RCnt).EntireColumn.ClearContents
    
    For y = 2 To UBound(d2)
        For x = 2 To RCnt
            If d2(y, 1) = ArrV(x, 1) Then ArrV(x, 18) = d2(y, 2)                                        'UniqueRefer Unit
            If d2(y, 1) = ArrV(x, 2) Then ArrV(x, 19) = d2(y, 2) & "-"                                  'UniqueRefer Para
            If d2(y, 1) = ArrV(x, 3) Then ArrV(x, 20) = d2(y, 2) & "-"                                  'UniqueRefer Role & Number
            If d2(y, 6) = ArrV(x, 5) Then ArrV(x, 21) = d2(y, 5) & ArrV(x, 9) & "-"                     'UniqueRefer Equipment and duplicates Number
                For z = 2 To UBound(d3)
                    If ArrV(x, 2) = d3(z, 1) Then ArrV(x, 19) = d3(z, 2) & "-"                          'Acronyms Company
                    If ArrV(x, 3) = d3(z, 1) Then ArrV(x, 20) = d3(z, 2) & ArrV(x, 9) & "-"             'Acronyms Role & Number
                    If ArrV(x, 5) = d3(z, 6) Then ArrV(x, 21) = d3(z, 5) & "-"                          'Acronyms Equipment
                Next z
            
            If ArrV(x, 1) = d1(x, 2) Then ArrV(x, 19) = ""
                
                
                If ArrV(x, 8) = "" Then
                If ArrV(x, 18) = "EXCON" And ArrV(x, 19) = "EXCON" Then Debug.Print ArrV(x, 18), ArrV(x, 19), ArrV(x, 20), ArrV(x, 21).Value
                    'roll          Equipment    Role & Num    Level         Unit
                    ArrV(x, 10) = ArrV(x, 21) & ArrV(x, 20) & ArrV(x, 19) & ArrV(x, 18)
                Else
                    ArrV(x, 10) = ArrV(x, 8) & ArrV(x, 21) & ArrV(x, 20) & ArrV(x, 19) & ArrV(x, 18)
                End If
                    Worksheets(strTab).Cells(x, 10) = ArrV(x, 10)
                    Worksheets(strTab).Cells(x, 11) = Len(ArrV(x, 10))
                        If Len(ArrV(x, 14)) > 30 Then
                            Worksheets(strTab).Cells(x, 10).Interior.ColorIndex = 3
                            Worksheets(strTab).Cells(x, 12) = Len(ArrV(x, 10)) - 30 & " Over"
                        End If
                If ArrV(x, 9) = "" Then Worksheets(strTab).Cells(x, 13) = 1
            If ArrV(x, 9) <> "" Then Worksheets(strTab).Cells(x, 13) = ArrV(x, 13)
        Next x
   Next y
    
    Sheets(strTab).Range("A1:O1").EntireColumn.AutoFit
    RCnt = 0


    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    Application.DisplayStatusBar = True
  
End Sub

**Minty** · 12-17-2022, 04:31 AM

You should just dump the results into another array then put the whole results array into the cells in one go - it's much more efficient.
Something like

Code:

 objWS.Range("A1:M" & iLastRow) = ResultData()

Where ResultData is the array you have stored the results in.

**Thompyt** · 12-17-2022, 04:23 PM

Minty,
Something like this?
objWkSht.Range("A1:Z" & RCnt) = ArrV("A1:Z" & RCnt).Value between Next x and Next y? Or close to it since this one gets an error. Where would you put it?

I think it already does wait until the end before it writes to the sheet. But I would like to keep the data TSR for other operations such as taking the roles names and assigning it to a sheet where the d1(x, 1) name is the same.

**Micron** · 12-17-2022, 04:41 PM

I guess it depends on your outlook. If it's fast enough and you don't envision the data set to get a whole lot larger, then you could move on.
Or you could tweak to minimize calls to the sheet and gain some knowledge in that respect and maybe wee bit of speed also. However, I have only started dabbling in such Excel methods in the last few months so I don't know if I'm the guy to write Excel array stuff for you at that level.

The suggested line is for writing ResultData() into the sheet in one go after you've populated the ResultData array. You can also dump an entire sheet range into an array in one go to avoid repeated calls to your sheet, then work with the array if that helps.

**Thompyt** · 12-17-2022, 04:58 PM

Micron,
Understand. What goes in the ResultData (???????) That is the part I am not getting.

**Micron** · 12-17-2022, 05:08 PM

I don't want to speak for Minty, but usually it's a range of cells if it's the input, the results if not. If you modify the array values but put those new values into the output array, when done you write the output array to the sheet. So all the processing is done with the arrays, and there's only 2 calls to the sheet - to get, then to put. You probably could find lots of web pages on the subject of using arrays in Excel and find some that teach how not to loop over the sheet (which might be another way of researching the topic).

**Minty** · 12-18-2022, 06:39 AM

Micron has hit the nail on the head. When I do this I dump the entire contents of the sheet into an array.
Do all the painful looping work on the array, and dump the results into the other results array as I go.

Only at the end do I use the code above to populate the results into the worksheet. It's significantly quicker on large chucks of data.
Processing 6000 rows for text strings goes from taking 10-15 minutes to 25 seconds, as you are missing out all the worksheet interactions.

So to put your data into the array initially I use

aData() = wsSource.Range("A1:C" & iLastRow)

Arrays read from, write to

Thread Tools

Arrays read from, write to

Similar Threads

Having a combo box read from one table and write to another?

DB opens as read only and won't let me write

Read/Write Access in Cells on Forms

Some Can Read; Some Can Write

Subform is Read Only, cant seem to make Read/Write, PL HELP!

Posting Permissions