Match & arrange data for multiple sheets based on another sheet

[KalilMe]

Hello
I want match all of the sheets for column B with sheet report for columns B:D then should arrange data in all of the sheets based on sheet report . with considering if I have new items in all sheets but are not existed in sheet REPORT , then should put in the last rows after arrange the items are matched . the result should be in the same range for each sheet but i put from column G to see how could be .
important notice : I have about 1400 rows across sheets so I put just dummy data in simple file . and I will add new sheets with the same structure if I need it , also when update data in all of sheets should not be problem when run macro repeatedly .
thanks

[bebo021999]

Option Explicit
Sub test()
Dim lr&, lc&, i&, j&, k&, t&, c&, ws As Worksheet
Dim report(), rng, arr()
With Worksheets("REPORT")
    lr = .Cells(Rows.Count, "B").End(xlUp).Row
    rng = .Range("B3:D" & lr).Value
    ReDim report(1 To lr, 1 To 1)
    For i = 1 To lr - 2
        report(i, 1) = rng(i, 1) & " " & rng(i, 2) & " " & rng(i, 3)
    Next
End With
For Each ws In Sheets
    k = 0
    If ws.Name <> "REPORT" Then
        lr = ws.Cells(Rows.Count, "B").End(xlUp).Row
        lc = ws.Cells(1, Columns.Count).End(xlToLeft).Column
        rng = ws.Range("A2", ws.Cells(lr, lc)).Value
        ReDim arr(1 To lr - 1, 1 To lc)
        For i = 1 To UBound(report)
            For j = 1 To UBound(rng)
                If report(i, 1) = rng(j, 2) Then
                    k = k + 1
                    For t = 1 To lc
                        arr(k, t) = rng(j, t)
                    Next
                    arr(k, 1) = k
                End If
            Next
        Next
        For i = 1 To UBound(rng)
            c = 0
            For j = 1 To UBound(arr)
                If rng(i, 2) = arr(j, 2) Then c = c + 1
            Next
            If c = 0 Then
                k = k + 1
                For t = 1 To lc
                    arr(k, t) = rng(i, t)
                Next
                arr(k, 1) = k
            End If
        Next
        ws.Range("A2").Resize(UBound(arr), lc).Value = arr
    End If
Next
End Sub 

[KalilMe]

magnificent !
just I want clarifying from you about your code . does the code deal with huge data?
I'm afraid to become slow when increase data . I don't want to come back to modifiying the code to deal with huge data .

[bebo021999]

try to duplicate data to 10,000 or even 100,000 rows, to see if it's acceptable.

[KalilMe]

ok I will do it and come back soon

[KalilMe]

what means this error subscript out of range in this line ?

Please Login or Register  to view this content.

I duplicate data to 28000 rows . by the way this error shows in the beginning I no know why and somtimes work without any problem .

[bebo021999]

I duplicate data to 28000 rows . by the way this error shows in the beginning I no know why and somtimes work without any problem .

May be this:

Dim lr&, lc&, i&, j&, k&, t&, c&

Can you try to replace
n&
by
n as long
?
If it does not work, try to attach new file with 28.000 rows again.

[KalilMe]

Can you try to replace
n&
by
n as long
?

I don't see any variable n in your code
can't upload file is too big . here is the link
https://www.dropbox.com/scl/fi/b19bt...ofy03ozwwp5eu7

[bebo021999]

I mean change lr&,lc&,... to lr as long, lc as long,... anuthing with trailing "&"

[KalilMe]

thanks . still the error shows. did you upload my file and see the problem , please?

[jindon]

Please Login or Register  to view this content.

[KalilMe]

@jindon appreciated for your code , but I no know if you see post#8 .when have huge data the code seem slow gives running speed 35.12 .
is it normal speed or you can make it better ?

[jindon]

If you are telling the truth, you should have many formulas running somewhere

Please Login or Register  to view this content.

[KalilMe]

@jindon thanks again
this is much better