Hi

Welcome to board !!

Try this

Code:
Option Explicit

Sub kTest()
    
    Dim k, q, t, i As Long, c As Long
    
    k = Sheet1.Range("a2:a" & Sheet1.Range("a" & Sheet1.Rows.Count).End(3).Row).Resize(, 13).Value2
    
    With CreateObject("scripting.dictionary")
        .comparemode = 1
        For c = 1 To UBound(k, 2)
            For i = 1 To UBound(k, 1)
                If LenB(k(i, c)) Then
                    t = .Item(k(i, c))
                    If Not IsEmpty(t) Then
                        t = Split(t, "_")(1)
                        .Item(k(i, c)) = k(i, c) & "_" & Val(t) + 1
                    Else
                        .Item(k(i, c)) = k(i, c) & "_" & 1
                    End If
                End If
            Next
        Next
        k = .items
    End With
    q = Filter(k, "_1", True)
    Sheet1.UsedRange.ClearContents
    Sheet1.Range("a2").Resize(UBound(q) + 1) = Application.Transpose(q)
    Sheet1.Range("a2").Resize(UBound(q) + 1).TextToColumns Sheet1.Range("a2"), 1, other:=1, otherchar:="_"
    q = Filter(k, "_1", False)
    Sheet2.UsedRange.ClearContents
    Sheet2.Range("a2").Resize(UBound(q) + 1) = Application.Transpose(q)
    Sheet2.Range("a2").Resize(UBound(q) + 1).TextToColumns Sheet2.Range("a2"), 1, other:=1, otherchar:="_"
    
End Sub