transpose data through multiple sheets calculate the values based on three datavalidation

any helps?

truly , it's good but I no know if you can fix somethings
first when selection from three data validations it should create the table by code and fill data without create table manually
the second also should create the formula in cell BALANCE by code but shows as value not formula
third when select another item from data validations should copy to the bottom but be carful if I return selecting the item are already existed in the bottom shouldn't repeat copying to the bottom again and if the data validations are empty then should create all the tables and fill the data by code
fourth If I change or add a new data in all sheets except summary then should update in sheet summary
I know this project is complicated but I trust in this forum contains many experts to do that

I really appreciate your assistance and effort

Multiple subroutines created in the attached file. I placed two buttons on the Summary sheet. The "Check Sel Exists" button is used to Check if the selected combination exists in the summary sheet. If it doesn't exists, then a new table is created in the summary page and the data is entered into Fourth tab. The 'populate summary' button populates the summary sheet pulling data from all the other sheets. Furthermore, any change to column E in the other sheets will fully update the summary sheet. The data validtion cells are populated through code with all the values that exist in the data.

Place these subroutines in a module

Sub sumrizegrpsscrtch()
'Populates SUMMARY page.
Dim k&, i&, j&, jn$, cl&, jnc$, jns$, lr&, lrs&
Dim t&, y&, u&, shft&, r&
Dim OutWB As Workbook
Dim ws As Worksheet, su As Worksheet
Dim a, b$()
Dim dict As Object
Dim pos As Range, posit As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
On Error GoTo ext
Set OutWB = ThisWorkbook
Set dict = CreateObject("Scripting.Dictionary")
Set su = OutWB.Sheets("SUMMARY")
lr = su.Cells(Rows.Count, 2).End(xlUp).Row + 10
su.Range("B5:I" & lr).ClearContents
su.Range("B5:I" & lr).ClearFormats
su.[B5:B13].Font.Color = 16777215
su.[B5:B12].Interior.Color = 13998939
su.[C5:C12].Interior.Color = 16247773
su.[B13].Interior.Color = 255
su.[C13].Interior.Color = 1137094
su.[B5:B13].Font.Bold = True
su.[B5:B13].Value = Application.Transpose(Array("BRAND", "TYPE", "ORIGIN", "FIRST", "IMPORT", "EXPORT", "RETURNS 1", "RETURNS 2", "BALANCE"))
su.[C13].FormulaR1C1 = "=R[-5]C+R[-4]C-R[-3]C-R[-2]C+R[-1]C"
With su.[B5:C13]
    .Borders(7).LineStyle = xlContinuous
    .Borders(7).Weight = xlThin
    .Borders(8).LineStyle = xlContinuous
    .Borders(8).Weight = xlThin        '
    .Borders(9).LineStyle = xlContinuous
    .Borders(9).Weight = xlThin
    .Borders(10).LineStyle = xlContinuous
    .Borders(10).Weight = xlThin
    .Borders(11).LineStyle = xlContinuous
    .Borders(11).Weight = xlThin
    .Borders(12).LineStyle = xlContinuous
    .Borders(12).Weight = xlThin
    '.SpecialCells(4).Value = 0
    '.NumberFormat = "0;-0;-;@"
End With
su.[C5:C13].HorizontalAlignment = xlCenter
With dict
k = 1
lrs = WorksheetFunction.RoundDown((lr - 4) / 3, 0)
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        jns = WorksheetFunction.Concat(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j))
        If Not .exists(jns) Then
            .Add jns, k
        End If
        k = k + 1
    Next j
Next i
For Each ws In OutWB.Worksheets
If InStr(ws.Name, "SUM") >= 1 Then GoTo skip
    a = ws.UsedRange
    If su.[C5] = "" Then
        Set pos = su.[C8]
    Else
        Set pos = su.[B5:B12].Find(Trim(ws.[E1]), , xlValues, xlWhole)
    End If
    For i = 2 To ws.Cells(Rows.Count, 1).End(xlUp).Row
        jnc = WorksheetFunction.Concat(a(i, 2), a(i, 3), a(i, 4))
        If .exists(jnc) And jnc <> "" Then
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If jnc = WorksheetFunction.Concat(su.Cells(y, u), su.Cells(y + 1, u), su.Cells(y + 2, u)) Then
                        shft = pos.Row - 5
                        su.Cells(y + shft, u).Value = su.Cells(y + shft, u).Value + a(i, 5)
                    End If
                Next
            Next
        Else
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If IsEmpty(su.Cells(y, u)) Then
                        Set posit = su.Cells(y, u)
                        GoTo fin
                    End If
                    r = r + 1
                Next
            Next
fin:
            r = r + 1
            If r >= lrs Then lr = lr + 10
            su.[B5:C13].Copy su.Cells(posit.Row, posit.Column - 1)
            posit.Value = a(i, 2)
            posit.Offset(1).Value = a(i, 3)
            posit.Offset(2).Value = a(i, 4)
            su.Range(posit.Offset(3), posit.Offset(7)).Value = 0
            shft = pos.Row - 5
            su.Cells(y + shft, u).Value = su.Cells(y + shft, u).Value + a(i, 5)
            .Add jnc, k
            k = k + 1
        End If
    Next i
skip:
Next ws
End With
For y = 5 To lr Step 10
    For u = 3 To 9 Step 3
        su.Cells(y + 8, u).Value = su.Cells(y + 8, u).Value
    Next
Next
Call dtvalid
ext:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Sub dtvalid()
'Populates Data validation
Dim k&, i&, j&, jn$, cl&, jnc$, jns$, lr&, lrs&
Dim t&, y&, u&, shft&, r&
Dim OutWB As Workbook
Dim su As Worksheet
Dim b$(), c$(), d$()
Dim dict As Object
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutWB = ThisWorkbook
Set dict = CreateObject("Scripting.Dictionary")
Set su = OutWB.Sheets("SUMMARY")
With dict
k = 1
lr = su.Cells(Rows.Count, 3).End(xlUp).Row
lrs = WorksheetFunction.RoundDown((lr - 4) / 3, 0)
ReDim b(1 To lrs)
ReDim c(1 To lrs)
ReDim d(1 To lrs)
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        If Not .exists(su.Cells(i, j).Value) Then
            .Add su.Cells(i, j).Value, k
            b(k) = su.Cells(i, j)
            'Debug.Print b(k)
            k = k + 1
        End If
    Next j
Next i
k = 1
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        If Not .exists(su.Cells(i + 1, j).Value) Then
            .Add su.Cells(i + 1, j).Value, k
            c(k) = su.Cells(i + 1, j)
            'Debug.Print C(k)
            k = k + 1
        End If
    Next j
Next i
k = 1
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        If Not .exists(su.Cells(i + 2, j).Value) Then
            .Add su.Cells(i + 2, j).Value, k
            d(k) = su.Cells(i + 2, j)
            'Debug.Print d(k)
            k = k + 1
        End If
    Next j
Next i
End With
b = SortArrayAtoZ(b)
c = SortArrayAtoZ(c)
d = SortArrayAtoZ(d)
    With su.[C2].Validation
    .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Join(b, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    With su.[D2].Validation
    .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Join(c, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    With su.[E2].Validation
    .Delete
        .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
        xlBetween, Formula1:=Join(d, ",")
        .IgnoreBlank = True
        .InCellDropdown = True
        .ShowInput = True
        .ShowError = True
    End With
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

Sub CheckSelExists()
'Checks if combination of validation fields exist as a table.
'Enters combination into the Fourth tab and summary tab if doesn't exist
Dim k&, i&, j&, jn$, cl&, jnc$, jns$, lr&, lrs&
Dim t&, y&, u&, r&, lrk&, g&
Dim OutWB As Workbook
Dim su As Worksheet
Dim a, b$()
Dim dict As Object
Dim posit As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutWB = ThisWorkbook
Set dict = CreateObject("Scripting.Dictionary")
Set su = OutWB.Sheets("SUMMARY")
If IsEmpty(su.[C2]) Or IsEmpty(su.[D2]) Or IsEmpty(su.[E2]) Then
    MsgBox "Atleast one selection is empty"
    GoTo ext
End If
If IsEmpty(su.[B5]) Then
    su.[B5:B13].Font.Color = 16777215
    su.[B5:B12].Interior.Color = 13998939
    su.[C5:C12].Interior.Color = 16247773
    su.[B13].Interior.Color = 255
    su.[C13].Interior.Color = 1137094
    su.[B5:B13].Font.Bold = True
    su.[B5:B13].Value = Application.Transpose(Array("BRAND", "TYPE", "ORIGIN", "FIRST", "IMPORT", "EXPORT", "RETURNS 1", "RETURNS 2", "BALANCE"))
    su.[C13].FormulaR1C1 = "=R[-5]C+R[-4]C-R[-3]C-R[-2]C+R[-1]C"
    With su.[B5:C13]
        .Borders(7).LineStyle = xlContinuous
        .Borders(7).Weight = xlThin
        .Borders(8).LineStyle = xlContinuous
        .Borders(8).Weight = xlThin        '
        .Borders(9).LineStyle = xlContinuous
        .Borders(9).Weight = xlThin
        .Borders(10).LineStyle = xlContinuous
        .Borders(10).Weight = xlThin
        .Borders(11).LineStyle = xlContinuous
        .Borders(11).Weight = xlThin
        .Borders(12).LineStyle = xlContinuous
        .Borders(12).Weight = xlThin
    '.SpecialCells(4).Value = 0
    '.NumberFormat = "0;-0;-;@"
    End With
    su.[C5:C13].HorizontalAlignment = xlCenter
End If
lr = su.Cells(Rows.Count, 2).End(xlUp).Row + 10
With dict
k = 1
lrs = WorksheetFunction.RoundDown((lr - 4) / 3, 0)
ReDim b(1 To lrs)
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        jns = WorksheetFunction.Concat(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j))
        If Not .exists(jns) Then
            .Add jns, k
            b(k) = jns
        End If
        k = k + 1
    Next j
Next i
jnc = WorksheetFunction.Concat(su.[C2], su.[D2], su.[E2])
        If .exists(jnc) Then
            For y = 5 To lr Step 10
                    For u = 3 To 9 Step 3
                        If jnc = WorksheetFunction.Concat(su.Cells(y, u), su.Cells(y + 1, u), su.Cells(y + 2, u)) Then
                        MsgBox "The combination exists at " & su.Cells(y, u - 1).Address
                        End If
                    Next
                Next
        Else
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If IsEmpty(su.Cells(y, u)) Then
                        Set posit = su.Cells(y, u)
                        GoTo fin
                    End If
                    r = r + 1
                Next
            Next
fin:
            r = r + 1
            su.[B5:C13].Copy su.Cells(posit.Row, posit.Column - 1)
            posit.Value = su.[C2].Value
            posit.Offset(1).Value = su.[D2].Value
            posit.Offset(2).Value = su.[E2].Value
            su.Range(posit.Offset(3), posit.Offset(8)).Value = 0
            
            With Sheets("FOURTH")
            For g = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
                If jnc = WorksheetFunction.Concat(.Cells(g, 2), .Cells(g, 3), .Cells(g, 4)) Then
                    GoTo skip
                End If
            Next
                lrk = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                .Cells(lrk, 1).Value = .Cells(lrk - 1, 1).Value + 1
                .Cells(lrk, 2).Value = su.[C2].Value
                .Cells(lrk, 3).Value = su.[D2].Value
                .Cells(lrk, 4).Value = su.[E2].Value
                .Cells(lrk, 5).Value = 0
            End With
skip:
            MsgBox "New table added at " & su.Cells(y, u - 1).Address
        End If

End With
Call dtvalid
ext:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Function SortArrayAtoZ(myArray As Variant)
'Sort the Array A-Z
Dim i As Long
Dim j As Long
Dim Temp
For i = LBound(myArray) To UBound(myArray) - 1
    For j = i + 1 To UBound(myArray)
        If UCase(myArray(i)) > UCase(myArray(j)) Then
            Temp = myArray(j)
            myArray(j) = myArray(i)
            myArray(i) = Temp
        End If
    Next j
Next i

SortArrayAtoZ = myArray

End Function

Place this subroutine in each other(not summary sheet) sheet module:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E:E")) Is Nothing Then
    Call sumrizegrpsscrtch
End If
End Sub

great work ! but still something is missed I no know if it's not clear also it supposes bring the item separately what I mean when select the first time the item from three data validation it should bring what I select not bring all and if I select another item it should copy to the bottom without repeat and if the data validations are empty then should brings all
thanks for your cooperation

Here is another iteration. You only need the "Check Sel Exists" button since if three validation fields are blank then the whole summary populates. Try it out and let me know how it fares. I updated the one module below.

Sub CheckSelExists()
'Checks if combination of validation fields exist as a table. Lists only the selected table
'Enters combination into the Fourth tab and summary tab if doesn't exist
Dim k&, i&, j&, jn$, cl&, jnc$, jns$, lr&, lrs&
Dim t&, y&, u&, r&, lrk&, g&
Dim OutWB As Workbook
Dim su As Worksheet
Dim a, b$()
Dim dict As Object
Dim posit As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
Call sumrizegrpsscrtch
Set OutWB = ThisWorkbook
Set dict = CreateObject("Scripting.Dictionary")
Set su = OutWB.Sheets("SUMMARY")
If IsEmpty(su.[C2]) Or IsEmpty(su.[D2]) Or IsEmpty(su.[E2]) Then
    'MsgBox "Atleast one selection is empty"
    GoTo ext
End If
If IsEmpty(su.[B5]) Then
    su.[B5:B13].Font.Color = 16777215
    su.[B5:B12].Interior.Color = 13998939
    su.[C5:C12].Interior.Color = 16247773
    su.[B13].Interior.Color = 255
    su.[C13].Interior.Color = 1137094
    su.[B5:B13].Font.Bold = True
    su.[B5:B13].Value = Application.Transpose(Array("BRAND", "TYPE", "ORIGIN", "FIRST", "IMPORT", "EXPORT", "RETURNS 1", "RETURNS 2", "BALANCE"))
    su.[C13].FormulaR1C1 = "=R[-5]C+R[-4]C-R[-3]C-R[-2]C+R[-1]C"
    With su.[B5:C13]
        .Borders(7).LineStyle = xlContinuous
        .Borders(7).Weight = xlThin
        .Borders(8).LineStyle = xlContinuous
        .Borders(8).Weight = xlThin        '
        .Borders(9).LineStyle = xlContinuous
        .Borders(9).Weight = xlThin
        .Borders(10).LineStyle = xlContinuous
        .Borders(10).Weight = xlThin
        .Borders(11).LineStyle = xlContinuous
        .Borders(11).Weight = xlThin
        .Borders(12).LineStyle = xlContinuous
        .Borders(12).Weight = xlThin
    '.SpecialCells(4).Value = 0
    '.NumberFormat = "0;-0;-;@"
    End With
    su.[C5:C13].HorizontalAlignment = xlCenter
End If
lr = su.Cells(Rows.Count, 2).End(xlUp).Row + 10
With dict
k = 1
lrs = WorksheetFunction.RoundDown((lr - 4) / 3, 0)
ReDim b(1 To lrs)
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        jns = WorksheetFunction.Concat(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j))
        If Not .exists(jns) Then
            .Add jns, k
            b(k) = jns
        End If
        k = k + 1
    Next j
Next i
jnc = WorksheetFunction.Concat(su.[C2], su.[D2], su.[E2])
        If .exists(jnc) Then
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If jnc = WorksheetFunction.Concat(su.Cells(y, u), su.Cells(y + 1, u), su.Cells(y + 2, u)) Then
                    'MsgBox "The combination exists at " & su.Cells(y, u - 1).Address
                    su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u)).Copy
                    su.[B5:C13].PasteSpecial xlPasteAll
                    su.Range("B15:I" & lr).ClearContents
                    su.Range("B15:I" & lr).ClearFormats
                    su.Range("E5:I13").ClearContents
                    su.Range("E5:I13").ClearFormats
                    End If
                Next
            Next
            
            
        Else
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If IsEmpty(su.Cells(y, u)) Then
                        Set posit = su.Cells(y, u)
                        GoTo fin
                    End If
                    r = r + 1
                Next
            Next
fin:
            r = r + 1
            su.[B5:C13].Copy su.Cells(posit.Row, posit.Column - 1)
            posit.Value = su.[C2].Value
            posit.Offset(1).Value = su.[D2].Value
            posit.Offset(2).Value = su.[E2].Value
            su.Range(posit.Offset(3), posit.Offset(8)).Value = 0
            
            With Sheets("FOURTH")
            For g = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
                If jnc = WorksheetFunction.Concat(.Cells(g, 2), .Cells(g, 3), .Cells(g, 4)) Then
                    GoTo skip
                End If
            Next
                lrk = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                .Cells(lrk, 1).Value = .Cells(lrk - 1, 1).Value + 1
                .Cells(lrk, 2).Value = su.[C2].Value
                .Cells(lrk, 3).Value = su.[D2].Value
                .Cells(lrk, 4).Value = su.[E2].Value
                .Cells(lrk, 5).Value = 0
            End With
skip:
            Call dtvalid
            'MsgBox "New table added at " & su.Cells(y, u - 1).Address
        End If

End With
'call dtvalid
ext:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

perfect but not completely it remains one thing if when I select the item from the first time it shows , but when I select a different item should copy to the bottom because a new item I think to mentioned that

if I select another item it should copy to the bottom without repeat

isn't clear my explanation ?

I thought that what you are asking for has been implemented. While one item is being displayed, and a new previously unexisting combination is entered, the summary page is updated with all the item combinations (tables) and the new item appears at the bottom of the summary page. Let me know if this explanation doesn’t align to yours.

yes I would that , but the code it doesn't do it you can check it , I select the item then show and when select a new item it replaces for what I searched earlier item

Do you mean that when you select a new(previuosly unexisting) combination, that the summary sheet is updated with all the items plus the new combination item at the bottom? I understood that is what you want. If you then select the button once more, then only that new combination shows up. I am unable to recreate a condition where a new item is selected and the previous search item shows up. If this answer still doesn't address your concern, please spell out each step with the original spreadsheet items so that I can try to recreate the condition.

all what you did is perfect and what I want
about this

a condition where a new item is selected and the previous search item shows up

yes this condition should be
for more from the first time select item it shows if I select another but is a new then should copy to bottom of previous searched item and so on to rest of new items which searches for them without repeat any item has already searched and existed

then you want that combination item/table to show up individually, right?

what you means combination , may you make clear more please ?
and do not forgot showing each three tables next to each of them

Here's another iteration. Try it out and let me know how it fares. I only had to update this one module.

Sub CheckSelExists()
'Checks if combination of validation fields exist as a table.
'Enters combination into the Fourth tab and summary tab if doesn't exist
Dim k&, i&, j&, jn$, cl&, jnc$, jns$, lr&, lrs&
Dim t&, y&, u&, r&, lrk&, g&, lri&, lrl&
Dim OutWB As Workbook
Dim su As Worksheet
Dim a, b$(), d
Dim dict As Object
Dim posit As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutWB = ThisWorkbook
Set dict = CreateObject("Scripting.Dictionary")
Set su = OutWB.Sheets("SUMMARY")
lri = su.Cells(Rows.Count, 2).End(xlUp).Row
If IsEmpty(su.[E5]) Then
    d = su.Range("B5:C" & lri).Value
    Debug.Print d(1, 1)
End If
Call sumrizegrpsscrtch
If IsEmpty(su.[C2]) Or IsEmpty(su.[D2]) Or IsEmpty(su.[E2]) Then
    'MsgBox "Atleast one selection is empty"
    GoTo ext
End If
lr = su.Cells(Rows.Count, 2).End(xlUp).Row + 20
With dict
k = 1
lrs = WorksheetFunction.RoundDown((lr - 4) / 3, 0)
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        jns = WorksheetFunction.Concat(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j))
        If Not .exists(jns) Then
            .Add jns, k
        End If
        k = k + 1
    Next j
Next i
jnc = WorksheetFunction.Concat(su.[C2], su.[D2], su.[E2])
        If .exists(jnc) Then
        lr = lr - 10
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If jnc = WorksheetFunction.Concat(su.Cells(y, u), su.Cells(y + 1, u), su.Cells(y + 2, u)) Then
                    'MsgBox "The combination exists at " & su.Cells(y, u - 1).Address
                    su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u)).Copy
                    su.[B5:C13].PasteSpecial xlPasteAll
                    su.Range("B15:I" & lr).ClearContents
                    su.Range("B15:I" & lr).ClearFormats
                    su.Range("E5:I13").ClearContents
                    su.Range("E5:I13").ClearFormats
                    End If
                Next
            Next
        Else
            With Sheets("FOURTH")
            For g = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
                If jnc = WorksheetFunction.Concat(.Cells(g, 2), .Cells(g, 3), .Cells(g, 4)) Then
                    GoTo skip
                End If
            Next
                lrk = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                Application.EnableEvents = False
                .Cells(lrk, 1).Value = .Cells(lrk - 1, 1).Value + 1
                .Cells(lrk, 2).Value = su.[C2].Value
                .Cells(lrk, 3).Value = su.[D2].Value
                .Cells(lrk, 4).Value = su.[E2].Value
                .Cells(lrk, 5).Value = 0
            End With
skip:
            su.Range("B5:I" & lr).ClearContents
            su.Range("B5:I" & lr).ClearFormats
            If IsEmpty(d) Then
                d = su.[B5:C13].Value
            Else
                su.Range("B5:C" & lri).Value = d
            End If
            For y = 5 To lr Step 10
                For u = 3 To 3 Step 3
                    If IsEmpty(su.Cells(y, u)) Then
                        Set posit = su.Cells(y, u)
                        GoTo fin
                    End If
                    r = r + 1
                Next
            Next
fin:
            r = r + 1
            su.[B5:C13].Copy su.Cells(posit.Row, posit.Column - 1)
            posit.Value = su.[C2].Value
            posit.Offset(1).Value = su.[D2].Value
            posit.Offset(2).Value = su.[E2].Value
            su.Range(posit.Offset(3), posit.Offset(8)).Value = 0
            'MsgBox "New table added at " & su.Cells(y, u - 1).Address
        End If

End With
        lrl = su.Cells(Rows.Count, 3).End(xlUp).Row
        For y = 5 To lrl Step 10
            If Cells(y, 3).Interior.Pattern = xlNone Then
                su.Range("B" & y & ":B" & y + 8).Font.Color = 16777215
                su.Range("B" & y & ":B" & y + 7).Interior.Color = 13998939
                su.Range("C" & y & ":C" & y + 7).Interior.Color = 16247773
                su.Range("B" & y + 8).Interior.Color = 255
                su.Range("C" & y + 8).Interior.Color = 1137094
                su.Range("B" & y & ":B" & y + 8).Font.Bold = True
                su.Range("B" & y & ":B" & y + 8).Value = Application.Transpose(Array("BRAND", "TYPE", "ORIGIN", "FIRST", "IMPORT", "EXPORT", "RETURNS 1", "RETURNS 2", "BALANCE"))
                su.Range("C" & y + 8).FormulaR1C1 = "=R[-5]C+R[-4]C-R[-3]C-R[-2]C+R[-1]C"
                With su.Range("B" & y & ":C" & y + 8)
                    .Borders(7).LineStyle = xlContinuous
                    .Borders(7).Weight = xlThin
                    .Borders(8).LineStyle = xlContinuous
                    .Borders(8).Weight = xlThin        '
                    .Borders(9).LineStyle = xlContinuous
                    .Borders(9).Weight = xlThin
                    .Borders(10).LineStyle = xlContinuous
                    .Borders(10).Weight = xlThin
                    .Borders(11).LineStyle = xlContinuous
                    .Borders(11).Weight = xlThin
                    .Borders(12).LineStyle = xlContinuous
                    .Borders(12).Weight = xlThin
                End With
                su.Range("C" & y & ":C" & y + 8).HorizontalAlignment = xlCenter
            End If
        Next y
ext:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

it gives error "object doesn't support this property or method " in this line

HTML Code: 

I updated the code to use the join function instead of the concat method. Otherwise it remains the same. That should resolve the error.

Sub CheckSelExists()
'Checks if combination of validation fields exist as a table.
'Enters combination into the Fourth tab and summary tab if doesn't exist
Dim k&, i&, j&, jn$, cl&, jnc$, jns$, lr&, lrs&
Dim t&, y&, u&, r&, lrk&, g&, lri&, lrl&
Dim OutWB As Workbook
Dim su As Worksheet
Dim a, b$(), d
Dim dict As Object
Dim posit As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutWB = ThisWorkbook
Set dict = CreateObject("Scripting.Dictionary")
Set su = OutWB.Sheets("SUMMARY")
lri = su.Cells(Rows.Count, 2).End(xlUp).Row
If IsEmpty(su.[E5]) And su.[C13].Value = 0 Then
    d = su.Range("B5:C" & lri).Value
End If
Call sumrizegrpsscrtch
Application.EnableEvents = False
Application.ScreenUpdating = False
If IsEmpty(su.[C2]) Or IsEmpty(su.[D2]) Or IsEmpty(su.[E2]) Then
    'MsgBox "Atleast one selection is empty"
    GoTo ext
End If
lr = su.Cells(Rows.Count, 2).End(xlUp).Row + 20
With dict
k = 1
lrs = WorksheetFunction.RoundDown((lr - 4) / 3, 0)
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        jns = Join(Array(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j)), "")
        If Not .exists(jns) Then
            .Add jns, k
        End If
        k = k + 1
    Next j
Next i
jnc = Join(Array(su.[C2], su.[D2], su.[E2]), "")
        If .exists(jnc) Then
        lr = lr - 10
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If jnc = Join(Array(su.Cells(y, u), su.Cells(y + 1, u), su.Cells(y + 2, u)), "") Then
                    'MsgBox "The combination exists at " & su.Cells(y, u - 1).Address
                    su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u)).Copy
                    su.[B5:C13].PasteSpecial xlPasteAll
                    su.Range("B15:I" & lr).ClearContents
                    su.Range("B15:I" & lr).ClearFormats
                    su.Range("E5:I13").ClearContents
                    su.Range("E5:I13").ClearFormats
                    End If
                Next
            Next
        Else
            With Sheets("FOURTH")
            For g = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
                If jnc = Join(Array(.Cells(g, 2), .Cells(g, 3), .Cells(g, 4)), "") Then
                    GoTo skip
                End If
            Next
                lrk = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                Application.EnableEvents = False
                .Cells(lrk, 1).Value = .Cells(lrk - 1, 1).Value + 1
                .Cells(lrk, 2).Value = su.[C2].Value
                .Cells(lrk, 3).Value = su.[D2].Value
                .Cells(lrk, 4).Value = su.[E2].Value
                .Cells(lrk, 5).Value = 0
            End With
skip:
            su.Range("B5:I" & lr).ClearContents
            su.Range("B5:I" & lr).ClearFormats
            If IsEmpty(d) Then
                d = su.[B5:C13].Value
            Else
                su.Range("B5:C" & lri).Value = d
            End If
            For y = 5 To lr Step 10
                For u = 3 To 3 Step 3
                    If IsEmpty(su.Cells(y, u)) Then
                        Set posit = su.Cells(y, u)
                        GoTo fin
                    End If
                    r = r + 1
                Next
            Next
fin:
            r = r + 1
            su.[B5:C13].Copy su.Cells(posit.Row, posit.Column - 1)
            posit.Value = su.[C2].Value
            posit.Offset(1).Value = su.[D2].Value
            posit.Offset(2).Value = su.[E2].Value
            su.Range(posit.Offset(3), posit.Offset(8)).Value = 0
            'MsgBox "New table added at " & su.Cells(y, u - 1).Address
        End If

End With
        lrl = su.Cells(Rows.Count, 3).End(xlUp).Row
        For y = 5 To lrl Step 10
            If Cells(y, 3).Interior.Pattern = xlNone Then
                su.Range("B" & y & ":B" & y + 8).Font.Color = 16777215
                su.Range("B" & y & ":B" & y + 7).Interior.Color = 13998939
                su.Range("C" & y & ":C" & y + 7).Interior.Color = 16247773
                su.Range("B" & y + 8).Interior.Color = 255
                su.Range("C" & y + 8).Interior.Color = 1137094
                su.Range("B" & y & ":B" & y + 8).Font.Bold = True
                su.Range("B" & y & ":B" & y + 8).Value = Application.Transpose(Array("BRAND", "TYPE", "ORIGIN", "FIRST", "IMPORT", "EXPORT", "RETURNS 1", "RETURNS 2", "BALANCE"))
                su.Range("C" & y + 8).FormulaR1C1 = "=R[-5]C+R[-4]C-R[-3]C-R[-2]C+R[-1]C"
                With su.Range("B" & y & ":C" & y + 8)
                    .Borders(7).LineStyle = xlContinuous
                    .Borders(7).Weight = xlThin
                    .Borders(8).LineStyle = xlContinuous
                    .Borders(8).Weight = xlThin        '
                    .Borders(9).LineStyle = xlContinuous
                    .Borders(9).Weight = xlThin
                    .Borders(10).LineStyle = xlContinuous
                    .Borders(10).Weight = xlThin
                    .Borders(11).LineStyle = xlContinuous
                    .Borders(11).Weight = xlThin
                    .Borders(12).LineStyle = xlContinuous
                    .Borders(12).Weight = xlThin
                End With
                su.Range("C" & y & ":C" & y + 8).HorizontalAlignment = xlCenter
            End If
        Next y
ext:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

thanks
but you still doesn't seem understand me , I put some results when I select more than a new item and how should show in sheet EXPECTED
please see the attached file

Here is an update. Let me know if it works as expected.

thanks
but it repeat copying the items have already existed if I search again for the same items it should just update if update in the others sheets without repeat copying again , may you fix it please ?

So you want to start with say 4 items as in your previous example. You then want to add to any of those four items in the other sheets. Then be able to come back to the summary sheet to see new changes in the 4 items, correct?

You then want to add to any of those four items in the other sheets. Then be able to come back to the summary sheet to see new changes in the 4 items, correct?

yes

So you want to start with say 4 items as in your previous example

but this I'm afraid not sure understand it
to be more clearly , the file in post#20 it's perfect but the problem if I select repeatedly for items has already existed it shouldn't copy again in the bottom just update if they change in others sheets , and if they are new items then should copy and add to the bottom in sheet summary

I've updated two modules. Let me know how it works.

Private Sub Worksheet_Change(ByVal Target As Range)
'adds new entry fields as item to summary page. Consolidates new data with full summary
Dim k&, i&, j&, jn$, cl&, jnc$, jns$, lr&, lrs&, ii&, jj&
Dim t&, y&, u&, r&, lrk&, g&, lrl&, f&, s&, c&, lrc&, lrcc&
Dim OutWB As Workbook
Dim su As Worksheet
Dim a, b$()
Dim dict As Object, dic As Object
Dim posit As Range, data As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
If Not Intersect(Target, Range("E:E")) Is Nothing Then
If Target.Cells.Count > 1 Then GoTo ext
    Set OutWB = ThisWorkbook
    Set dict = CreateObject("Scripting.Dictionary") ' Initial summary items
    Set dic = CreateObject("Scripting.Dictionary") ' full summary items
    Set su = OutWB.Sheets("SUMMARY")
    If IsEmpty(Target.Offset(, -3)) Or IsEmpty(Target.Offset(, -2)) Or IsEmpty(Target.Offset(, -1)) Then
        'sts = False
        GoTo ext
    End If
    lr = su.Cells(Rows.Count, 2).End(xlUp).Row + 20
    k = 1
    lrs = WorksheetFunction.RoundDown((lr - 4) / 3, 0)
    ReDim b(1 To lrs, 1 To 9)
    For i = 5 To lr Step 10
        For j = 3 To 9 Step 3
            jns = Join(Array(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j)), "")
            If Not dict.exists(jns) Then
                dict.Add jns, k
                b(k, 1) = jns
                b(k, 2) = su.Cells(i, j)
                b(k, 3) = su.Cells(i + 1, j)
                b(k, 4) = su.Cells(i + 2, j)
                k = k + 1
            End If
        Next j
    Next i

    jnc = Join(Array(Target.Offset(, -3), Target.Offset(, -2), Target.Offset(, -1)), "")
    'if an item does show up in the full summary it must show those results
        'Check if item is in full summary
            'Collect full summary into array
    Call sumrizegrpsscrtch
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    lrc = su.Cells(Rows.Count, 2).End(xlUp).Row + 20
    lrcc = WorksheetFunction.RoundDown((lrc - 4) / 3, 0)
    ReDim a(1 To lrcc, 1 To 9)
    k = 1
    For i = 5 To lrc Step 10
        For j = 3 To 9 Step 3
            jns = Join(Array(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j)), "")
            If Not dic.exists(jns) Then
                dic.Add jns, k
                a(k, 1) = jns
                a(k, 2) = su.Cells(i, j)
                a(k, 3) = su.Cells(i + 1, j)
                a(k, 4) = su.Cells(i + 2, j)
                a(k, 5) = su.Cells(i + 3, j)
                a(k, 6) = su.Cells(i + 4, j)
                a(k, 7) = su.Cells(i + 5, j)
                a(k, 8) = su.Cells(i + 6, j)
                a(k, 9) = su.Cells(i + 7, j)
                k = k + 1
            End If
        Next j
    Next i
            'Update items that exists with full summary data
    For ii = LBound(b) To UBound(b)
        For jj = LBound(a) To UBound(a)
            If b(ii, 1) = a(jj, 1) Then
                b(ii, 4) = a(jj, 4)
                b(ii, 5) = a(jj, 5)
                b(ii, 6) = a(jj, 6)
                b(ii, 7) = a(jj, 7)
                b(ii, 8) = a(jj, 8)
                b(ii, 9) = a(jj, 9)
            End If
        Next jj
    Next ii
            'Clear summary page
    lrk = su.Cells(Rows.Count, 2).End(xlUp).Row
    su.Range("B5:I" & lrk).ClearContents
    su.Range("B5:I" & lrk).ClearFormats
            'Add initial items back to summary page
    k = 1
    For y = 5 To lr Step 10
        For u = 3 To 9 Step 3
            su.Cells(y, u).Value = b(k, 2)
            su.Cells(y + 1, u).Value = b(k, 3)
            su.Cells(y + 2, u).Value = b(k, 4)
            su.Cells(y + 3, u).Value = b(k, 5)
            su.Cells(y + 4, u).Value = b(k, 6)
            su.Cells(y + 5, u).Value = b(k, 7)
            su.Cells(y + 6, u).Value = b(k, 8)
            su.Cells(y + 7, u).Value = b(k, 9)
            k = k + 1
        Next u
    Next y
    'if item doesn't exist in initial summary
    If Not dict.exists(jnc) Then
            'find next open position
        For y = 5 To lr Step 10
            For u = 3 To 9 Step 3
                If IsEmpty(su.Cells(y, u)) Then
                    Set posit = su.Cells(y, u)
                    GoTo fin
                End If
                r = r + 1
            Next u
        Next y
fin:
        'if not in full summary then add new zero'd item to summary page
        If Not dic.exists(jnc) Then
                r = r + 1
                su.[B5:C13].Copy su.Cells(posit.Row, posit.Column - 1)
                su.Range(posit.Offset(3), posit.Offset(8)).Value = 0
                posit.Value = Target.Offset(, -3).Value
                posit.Offset(1).Value = Target.Offset(, -2)
                posit.Offset(2).Value = Target.Offset(, -1)
        'if item in full summary and not in initial page, pull that item into current summary page
        Else
            For k = LBound(a) To UBound(a)
                    If jnc = a(k, 1) Then
                        su.Cells(y, u).Value = a(k, 2)
                        su.Cells(y + 1, u).Value = a(k, 3)
                        su.Cells(y + 2, u).Value = a(k, 4)
                        su.Cells(y + 3, u).Value = a(k, 5)
                        su.Cells(y + 4, u).Value = a(k, 6)
                        su.Cells(y + 5, u).Value = a(k, 7)
                        su.Cells(y + 6, u).Value = a(k, 8)
                        su.Cells(y + 7, u).Value = a(k, 9)
                    End If
            Next k
        End If
    End If
        'Reformat items
    lrl = su.Cells(Rows.Count, 3).End(xlUp).Row
    For y = 5 To lrl Step 10
        For u = 3 To 9 Step 3
            If su.Cells(y, u).Interior.Pattern = xlNone And Not IsEmpty(su.Cells(y, u)) Then
                su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u - 1)).Font.Color = 16777215
                su.Range(su.Cells(y, u - 1), su.Cells(y + 7, u - 1)).Interior.Color = 13998939
                su.Range(su.Cells(y, u), su.Cells(y + 7, u)).Interior.Color = 16247773
                su.Cells(y + 8, u - 1).Interior.Color = 255
                su.Cells(y + 8, u).Interior.Color = 1137094
                su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u - 1)).Font.Bold = True
                su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u - 1)).Value = Application.Transpose(Array("BRAND", "TYPE", "ORIGIN", "FIRST", "IMPORT", "EXPORT", "RETURNS 1", "RETURNS 2", "BALANCE"))
                su.Cells(y + 8, u).FormulaR1C1 = "=R[-5]C+R[-4]C-R[-3]C-R[-2]C+R[-1]C"
                With su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u))
                    .Borders(7).LineStyle = xlContinuous
                    .Borders(7).Weight = xlThin
                    .Borders(8).LineStyle = xlContinuous
                    .Borders(8).Weight = xlThin        '
                    .Borders(9).LineStyle = xlContinuous
                    .Borders(9).Weight = xlThin
                    .Borders(10).LineStyle = xlContinuous
                    .Borders(10).Weight = xlThin
                    .Borders(11).LineStyle = xlContinuous
                    .Borders(11).Weight = xlThin
                    .Borders(12).LineStyle = xlContinuous
                    .Borders(12).Weight = xlThin
                End With
                su.Range(su.Cells(y, u), su.Cells(y + 8, u)).HorizontalAlignment = xlCenter
            End If
            su.Cells(y + 8, u).Value = su.Cells(y + 8, u).Value
        Next u
    Next y
ext:
End If
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

and

Sub CheckSelExists()
'Checks if combination of validation fields exist as a table.
'Enters combination into the Fourth tab and summary tab if doesn't exist
Dim k&, i&, j&, jn$, cl&, jnc$, jns$, lr&, lrs&, lrc&, lrcc&
Dim t&, y&, u&, r&, lrk&, g&, lri&, lrl&, lc&, f&, s&
Dim OutWB As Workbook
Dim su As Worksheet
Dim a, b$(), d, dt
Dim dict As Object
Dim posit As Range, posit2 As Range, data As Range
Application.EnableEvents = False
Application.ScreenUpdating = False
Set OutWB = ThisWorkbook
Set dict = CreateObject("Scripting.Dictionary")
Set su = OutWB.Sheets("SUMMARY")
If IsEmpty(su.[C2]) Or IsEmpty(su.[D2]) Or IsEmpty(su.[E2]) Then
    'MsgBox "Atleast one selection is empty"
    Call sumrizegrpsscrtch
    sts = False
    GoTo ext
End If
lri = su.Cells(Rows.Count, 2).End(xlUp).Row
lc = su.Cells(5, Columns.Count).End(xlToLeft).Column
jnc = Join(Array(su.[C2], su.[D2], su.[E2]), "")
If sts = True Then
    d = su.Range(su.[B5], su.Cells(lri, lc)).Value
    'Check if selection already exists
    lrc = su.Cells(Rows.Count, 2).End(xlUp).Row + 20
    k = 1
    lrcc = WorksheetFunction.RoundDown((lrc - 4) / 3, 0)
    ReDim b(1 To lrcc, 1 To 9)
    For i = 5 To lrc Step 10
        For j = 3 To 9 Step 3
            jns = Join(Array(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j)), "")
            If Not dict.exists(jns) Then
                dict.Add jns, k
                b(k, 1) = jns
                b(k, 2) = su.Cells(i, j)
                b(k, 3) = su.Cells(i + 1, j)
                b(k, 4) = su.Cells(i + 2, j)
                k = k + 1
                If jns = jnc Then GoTo ext
            End If
        Next j
    Next i
End If
Call sumrizegrpsscrtch
Application.EnableEvents = False
Application.ScreenUpdating = False
lr = su.Cells(Rows.Count, 2).End(xlUp).Row + 20
With dict
k = 1
lrs = WorksheetFunction.RoundDown((lr - 4) / 3, 0)
For i = 5 To lr Step 10
    For j = 3 To 9 Step 3
        jns = Join(Array(su.Cells(i, j), su.Cells(i + 1, j), su.Cells(i + 2, j)), "")
        If Not .exists(jns) Then
            .Add jns, k
        End If
        k = k + 1
    Next j
Next i

        If .exists(jnc) Then
            'lr = lr - 10
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If jnc = Join(Array(su.Cells(y, u), su.Cells(y + 1, u), su.Cells(y + 2, u)), "") Then
                    dt = su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u))
                    su.Range("B5:I" & lr).ClearContents
                    su.Range("B5:I" & lr).ClearFormats
                    su.Range("E5:I13").ClearContents
                    su.Range("E5:I13").ClearFormats
                    GoTo leav
                    End If
                Next
            Next
leav:
            su.Range(su.[B5], su.Cells(lri, lc)).Value = d
            For f = 5 To lr Step 10
                For s = 3 To 9 Step 3
                    If IsEmpty(su.Cells(f, s)) Then
                        Set posit2 = su.Cells(f, s)
                        GoTo mve
                    End If
                    r = r + 1
                Next
            Next
mve:

        su.Range(su.Cells(f, s - 1), su.Cells(f + 8, s)).Value = dt

        Else
            With Sheets("FOURTH")
            For g = 1 To .Cells(Rows.Count, 1).End(xlUp).Row
                If jnc = Join(Array(.Cells(g, 2), .Cells(g, 3), .Cells(g, 4)), "") Then
                    GoTo skip
                End If
            Next
                lrk = .Cells(Rows.Count, 1).End(xlUp).Row + 1
                Application.EnableEvents = False
                .Cells(lrk, 1).Value = .Cells(lrk - 1, 1).Value + 1
                .Cells(lrk, 2).Value = su.[C2].Value
                .Cells(lrk, 3).Value = su.[D2].Value
                .Cells(lrk, 4).Value = su.[E2].Value
                .Cells(lrk, 5).Value = 0
            End With
skip:
            su.Range("B5:I" & lr).ClearContents
            su.Range("B5:I" & lr).ClearFormats
            If IsEmpty(d) Then
                d = su.[B5:C13].Value
            Else
                su.Range("B5", Cells(lri, lc)).Value = d
            End If
            For y = 5 To lr Step 10
                For u = 3 To 9 Step 3
                    If IsEmpty(su.Cells(y, u)) Then
                        Set posit = su.Cells(y, u)
                        GoTo fin
                    End If
                    r = r + 1
                Next
            Next
fin:
            r = r + 1
            su.[B5:C13].Copy su.Cells(posit.Row, posit.Column - 1)
            posit.Value = su.[C2].Value
            posit.Offset(1).Value = su.[D2].Value
            posit.Offset(2).Value = su.[E2].Value
            su.Range(posit.Offset(3), posit.Offset(8)).Value = 0
        End If

End With
        lrl = su.Cells(Rows.Count, 3).End(xlUp).Row
        For y = 5 To lrl Step 10
            For u = 3 To 9 Step 3
            If Cells(y, u).Interior.Pattern = xlNone And Cells(y, u) <> "" Then
                su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u - 1)).Font.Color = 16777215
                su.Range(su.Cells(y, u - 1), su.Cells(y + 7, u - 1)).Interior.Color = 13998939
                su.Range(su.Cells(y, u), su.Cells(y + 7, u)).Interior.Color = 16247773
                su.Cells(y + 8, u - 1).Interior.Color = 255
                su.Cells(y + 8, u).Interior.Color = 1137094
                su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u - 1)).Font.Bold = True
                su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u - 1)).Value = Application.Transpose(Array("BRAND", "TYPE", "ORIGIN", "FIRST", "IMPORT", "EXPORT", "RETURNS 1", "RETURNS 2", "BALANCE"))
                su.Cells(y + 8, u).FormulaR1C1 = "=R[-5]C+R[-4]C-R[-3]C-R[-2]C+R[-1]C"
                With su.Range(su.Cells(y, u - 1), su.Cells(y + 8, u))
                    .Borders(7).LineStyle = xlContinuous
                    .Borders(7).Weight = xlThin
                    .Borders(8).LineStyle = xlContinuous
                    .Borders(8).Weight = xlThin        '
                    .Borders(9).LineStyle = xlContinuous
                    .Borders(9).Weight = xlThin
                    .Borders(10).LineStyle = xlContinuous
                    .Borders(10).Weight = xlThin
                    .Borders(11).LineStyle = xlContinuous
                    .Borders(11).Weight = xlThin
                    .Borders(12).LineStyle = xlContinuous
                    .Borders(12).Weight = xlThin
                End With
                su.Range(su.Cells(y, u), su.Cells(y + 8, u)).HorizontalAlignment = xlCenter
            End If
            su.Cells(y + 8, u).Value = su.Cells(y + 8, u).Value
            Next u
        Next y
        sts = True
Set dict = Nothing
ext:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

amazing !! thanks so much for achieving this project , just I would show message when fill in data validations c2,d2,e2 are doesn't matched for any each sheet then should show message "the items are not available , please Verify that the data is correct " and when show the value is 0 for some item I would change to hyphen "- "
thanks for your cooperation.

Here you go. I added the below code to the formatting section

.NumberFormat = "0;-0;-;@"

and updated the the code to ask 'The items are not available , please verify that the data is correct. Do you want to create a new item?'

astonishing ! thanks for provide me this a great project
you're the best