مشكلة ظهور رسالة عند نسخ البيانات بشكل افقي

Sub TransposeUnique()

If ActiveSheet.Name <> "sheet1" Then Exit Sub

  Dim d As Object, ky

  Dim a As Range, i%, m%

  Dim St

   

   Range("G2").CurrentRegion.Clear

   Set d = CreateObject("Scripting.Dictionary")

   Set a = Range("A2", Range("E1").End(4))

   With a

    For i = 1 To .Rows.Count

      St = Application.Transpose(Application.Transpose(.Rows(i)))

      St = Join(St, "*")

      d(St) = ""

    Next i

   End With

   For Each ky In d.keys

    Cells(m + 2, "G").Resize(, a.Columns.Count) = Split(ky, "*")

    m = m + 1

   Next

   

   With Range("G2").CurrentRegion

   .Borders.LineStyle = 1

   .InsertIndent 1

   .Font.Bold = True

   .Interior.ColorIndex = 19

   .Value = .Value

   End With

End Sub

Option Explicit

Sub TransposeUnique_Salim()

Dim Sh As Worksheet

  Dim First_Ar

  Dim My_Dict As Object

  Dim i As Long, m As Long

  Dim mot

  Dim My_rg  As Range, ky

   m = 2

  Set Sh = Sheets("sheet1")

  If ActiveSheet.Name <> Sh.Name Then Exit Sub

  Set My_rg = Sh.Range("A2", Range("E1").End(4))

  Set My_Dict = CreateObject("Scripting.Dictionary")

 Sh.Range("G2").CurrentRegion.Clear



    For i = 2 To My_rg.Rows.Count

     mot = My_rg.Columns(1).Cells(i)

     First_Ar = Application.Transpose(My_rg.Columns(2). _

     Cells(i).Resize(, My_rg.Columns.Count - 1))

     First_Ar = Application.Transpose(First_Ar)

     First_Ar = Join(First_Ar, "*")

          If Not My_Dict.exists(mot) Then

           My_Dict(mot) = First_Ar

          Else

           My_Dict(mot) = My_Dict(mot) & "*" & First_Ar

          End If

      Next

    '+++++++++++++++++++++++++++++++++++

    If My_Dict.Count = 0 Then Exit Sub

    For Each ky In My_Dict.keys

     Cells(m, "G") = ky

     Cells(m, "H").Resize(, UBound(Split(My_Dict(ky), "*")) + 1) = _

     Split(My_Dict(ky), "*")

      m = m + 1

    Next

  My_Dict.RemoveAll

    '+++++++++++++++++++++++++++++++++++++

With Sh.Range("G2").CurrentRegion

.Borders.LineStyle = 1

   .InsertIndent 1

   .Font.Bold = True

   .Interior.ColorIndex = 19

   .Value = .Value

   .Columns.AutoFit

End With



End Sub

Option Explicit

Sub TransposeUnique_Salim_UPdated()

Dim Sh As Worksheet

  Dim First_Ar

  Dim My_Dict As Object

  Dim i As Long, m As Long

  Dim mot, AR

  Dim My_rg  As Range, ky

   m = 2

  Set Sh = Sheets("sheet1")

  If ActiveSheet.Name <> Sh.Name Then Exit Sub

  Set My_rg = Sh.Range("A2", Range("E1").End(4))

  Set My_Dict = CreateObject("Scripting.Dictionary")

 Sh.Range("G2").CurrentRegion.Clear



    For i = 2 To My_rg.Rows.Count + 1

      mot = My_rg.Columns(1).Cells(i - 1)

      First_Ar = Application.Transpose(My_rg.Columns(2). _

     Cells(i - 1).Resize(, My_rg.Columns.Count - 1))

     First_Ar = Application.Transpose(First_Ar)

     First_Ar = Join(First_Ar, "*")

          If Not My_Dict.exists(mot) Then

           My_Dict(mot) = First_Ar

          Else

           My_Dict(mot) = My_Dict(mot) & "*" & First_Ar

          End If

      Next

    '+++++++++++++++++++++++++++++++++++

    If My_Dict.Count = 0 Then Exit Sub

    For Each ky In My_Dict.keys

    AR = Split(My_Dict(ky), "*")

     Cells(m, "G") = ky

     Cells(m, "H").Resize(, UBound(Split(My_Dict(ky), "*")) + 1) = _

     Split(My_Dict(ky), "*")

      m = m + 1

    Next

  My_Dict.RemoveAll

    '+++++++++++++++++++++++++++++++++++++

With Sh.Range("G2").CurrentRegion.SpecialCells(2)

   .Borders.LineStyle = 1

   .InsertIndent 1

   .Font.Bold = True

   .Interior.ColorIndex = 19

   .Columns.AutoFit

  End With



End Sub

Sub TransposeUnique()

    Dim a, e, v, d As Object, s As String, i As Long, j As Long, x As Long

    With ThisWorkbook.Worksheets("Sheet1")

        Set d = CreateObject("Scripting.Dictionary")

        a = .Range("A2", .Range("E" & Rows.Count).End(xlUp)).Value

        For i = LBound(a, 1) To UBound(a, 1)

            s = Empty

            For j = LBound(a, 2) + 1 To UBound(a, 2)

                s = s & ";" & a(i, j)

            Next j

            d(a(i, 1)) = d(a(i, 1)) & s

        Next i

        With .Range("G2")

            .Resize(d.Count).Value = Application.Transpose(d.Keys)

            For Each e In d.Items

                v = Split(Mid(e, 2, Len(e)), ";")

                .Offset(x, 1).Resize(, UBound(v) + 1).Value = v

                x = x + 1

            Next e

        End With

    End With

End Sub

Sub TransposeUnique()

    Dim a, e, SaLim As Object

    Dim s As String, i As Long

    Dim j As Long, x As Long

    

    With ThisWorkbook.Worksheets("Sheet1")

       .Range("G2").CurrentRegion.ClearContents

        Set SaLim = CreateObject("Scripting.Dictionary")

        a = .Range("A2", .Range("E" & Rows.Count).End(3)).Value

        For i = LBound(a, 1) To UBound(a, 1)

            s = Empty

              For j = LBound(a, 2) + 1 To UBound(a, 2)

                  s = IIf(s = Empty, a(i, j), s & " " & a(i, j))

              Next j

            SaLim(a(i, 1)) = SaLim(a(i, 1)) & s

        Next i

        

        With .Range("G2")

            .Resize(SaLim.Count).Value = _

             Application.Transpose(SaLim.Keys)

              For Each e In SaLim.Items

                .Offset(x, 1).Resize(, _

                 UBound(Split(e)) + 1).Value = Split(e)

                 x = x + 1

              Next e

        End With

   End With

End Sub