Excel vba - Match Data

[vincentzack]

My code need more than one hours to complete for 3500 rows data but I need to work for more than 40000 rows data.
I am looking for alternatives to my code by using dictionary, with improved performance within the context of interest.
Could anyone help me?

Sub StripRow2Node()

'Read the Strip Design table
With Sheets("Design-Moment")
Sheets("Design-Moment").Activate
LastR1 = .Range("B" & Cells.Rows.Count).End(xlUp).Row
DM_arr = .Range(Cells(1, 1), Cells(LastR1, 7)) 'Col 1 to Col 7
DM_count = UBound(DM_arr, 1)
End With

'Read the x and y coordinations and thickness of a node in node design
With Sheets("Design-Shear")
Sheets("Design-Shear").Activate
LastR2 = .Range("B" & Cells.Rows.Count).End(xlUp).Row
DS_arr = .Range(Cells(1, 4), Cells(LastR2, 5)) 'Col 4 to Col 5
SX_arr = .Range(Cells(1, 26), Cells(LastR2, 27))
SY_arr = .Range(Cells(1, 30), Cells(LastR2, 31))
DS_count = UBound(DS_arr, 1)
End With

'** Find correponding reference row in Design-Moment for nodes**

'Match node to striip station and output row index
For i = 5 To DS_count
XStrip = SX_arr(i, 1)
XStation = DS_arr(i, 1)
YStrip = SY_arr(i, 1)
YStation = DS_arr(i, 2)

For j = 5 To DM_count
If DM_arr(j, 1) = XStrip Then 'X-Strip Name is matched
If DM_arr(j, 4) >= XStation And DM_arr(j - 1, 4) < XStation Then
SX_arr(i, 2) = j 'matched row reference for X-strip
End If
End If

If DM_arr(j, 1) = YStrip Then
If DM_arr(j, 5) <= YStation And DM_arr(j - 1, 5) > YStation Then
SY_arr(i, 2) = j
End If
End If

Next j
Next i

'Write the matched strip information to node
For i = 5 To LastR2
With Sheets("Design-Shear")
.Cells(i, 27) = SX_arr(i, 2)
.Cells(i, 31) = SY_arr(i, 2)
End With
Next i
End sub

[mdmackillop]

Welcome to VBAX
Can you post a sample file? Use Go Advanced/Manage Attachments

[Paul_Hossler]

Also with a sample of the 'After' also please

[vincentzack]

Attached excel file after run the code.

Is is possible to speed up by rewriting the code with using "Scripting Dictionary"?

Thank you very much!

[snb]

Also with a sample of the 'After' also please

What after ? Morning after ??

[mdmackillop]

Your sample does not appear to return any valid data. Writing the results though could do without the loop

    With Sheets("Design-Shear")
        .Cells(5, 27).Resize(lastr2, 2) = SX_arr
        .Cells(5, 31).Resize(lastr2, 2) = Sy_arr
    End With

[snb]

@vincent can you describe in words what should happen when the first 'record' in the sheet 'design-moment' has been read ?

Which elements of the record will be used to search for in the other sheet ?
Where will these elements be searched in in the other sheet ?
Which elements in the other sheet have to be adapted and by what data ?

[SamT]

This compiles. Obviously I have no way to test it.

Sub StripRow2Node()
     
     'Read the Strip Design table
    With Sheets("Design-Moment")
         DM_arr = .Range(Cells(1, 1), Cells(.Rows.Count, "B").End(xlUp).Offset(, 4)) 'Col 1 to Col 5
    End With
     
     'Read the x and y coordinations and thickness of a node in node design
    With Sheets("Design-Shear")
        LastR2 = .Range("B" & Cells.Rows.Count).End(xlUp).Row
        
        DS_arr = .Range(Cells(1, 4), Cells(LastR2, 5)) 'Col 4 to Col 5
        SX_arr = .Range("Z1:Z" & LastR2)
        SY_arr = .Range("AD1:AD" & LastR2)
   End With
   ReDim XRow_arr(UBound(SX_arr))
   ReDim YRow_arr(UBound(SY_arr))
   
     '** Find correponding reference row in Design-Moment for nodes**
     
     'Match node to striip station and output row index
    For i = 5 To UBound(DS_arr, 1)
       YStrip = SY_arr(i)
        
        FoundX = 0: FoundY = 0
        For j = 5 To UBound(DM_arr, 1)
            If DM_arr(j, 1) = SX_arr(i) Then '
                If DM_arr(j, 4) >= DM_arr(j - 1, 4) And DM_arr(j - 1, 4) < XStation Then
                    XRow_arr(i) = j 'matched row reference for X-strip
                End If
            End If
             
            If DM_arr(j, 1) = SY_arr(i) Then
                If DM_arr(j, 5) <= DM_arr(j - 1, 5) And DM_arr(j - 1, 5) > DS_arr(i, 2) Then
                    YRow_arr(i) = j
                End If
            End If
            
            If XRow_arr(i) * YRow_arr(i) Then Exit For 'Unassigned = 0 = False
        Next j
    Next i
     
     'Write the matched strip information to node
     Application.ScreenUpdating = False
         With Sheets("Design-Shear")
            Tmp_arr = .Range("AA1:AA4")
            .Range("AA1").Resize(UBound(XRow_arr)) = XRow_arr
            .Range("AA1:AA4") = Tmp_arr
            
            Tmp_arr = .Range("AE1:AE4")
            .Range("AE1").Resize(UBound(YRow_arr)) = YRow_arr
            .Range("AE1:AE4") = Tmp_arr
        End With
        Application.ScreenUpdating = True
End Sub

Edit: Oooooops. I shrank one array too far.

[Paul_Hossler]

What after ? Morning after ??