أكاديمية الصقر للتدريب

لوحة التميز الأسبوعي
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
العضو المتميز المشرف المتميز المراقب المتميز المدير المتميز الموضوع المتميز القسم المتميز
ashraf_hertlion hassona229-- لا تميز خلال هذه الفترة YasserKhalil مطلوب تعديل الكود للطباعة اكسيل اسئله واجابات


أهلا وسهلا بك زائرنا الكريم في أكاديمية الصقر للتدريب، لكي تتمكن من المشاركة ومشاهدة جميع أقسام المنتدى وكافة الميزات ، يجب عليك إنشاء حساب جديد بالتسجيل بالضغط هنا أو تسجيل الدخول اضغط هنا إذا كنت عضواً .





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

السلام عليكم اتمنى من الاخوة علاج مشكلة ظهور رسالة عن تشغيل الكود quot;هل تريد استبدال محتويات خلايا ال ..


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


24-05-2020 08:08 مساء
المبتدأ
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس : ذكر
تاريخ الميلاد : 17-8-1981
يتابعهم : 0
يتابعونه : 2
قوة السمعة : 244
 offline 

السلام  عليكم  
اتمنى  من  الاخوة  علاج  مشكلة  ظهور  رسالة  عن تشغيل  الكود   "هل تريد  استبدال  محتويات  خلايا  الوجهة " 
Sub TransposeUnique()
  Dim d As Object
  Dim a As Variant
  Dim i As Long
  
  Set d = CreateObject("Scripting.Dictionary")
  a = Range("A2", Range("E" & Rows.Count).End(xlUp)).Value
  For i = 1 To UBound(a)
    d(a(i, 1)) = d(a(i, 1)) & ";" & a(i, 2) & ";" & a(i, 3) & ";" & a(i, 4) & ";" & a(i, 5)
  Next i
  With Range("G2:h2").Resize(d.Count)
    .Value = Application.Transpose(Array(d.Keys, d.Items))
    .Columns(2).TextToColumns DataType:=xlDelimited, Semicolon:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 9))
  End With
End Sub
 
 
  واصلاح كود نقل البيانات بشكل راسي ‬.xlsm   تحميل xlsm مرات التحميل :(4)
الحجم :(20.731) KB



أفضل إجابة مقدمة من YasserKhalil وهي:
بارك الله فيك أخي العزيز سليم وكل عام وأنت وجميع الأعضاء بخير
إثراءً للموضوع إليك أخي الكريم التعديل التالي ..
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
عرض الإجابة




24-05-2020 11:11 مساء
مشاهدة مشاركة منفردة [1]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مشكلة ظهور رسالة عند نسخ البيانات بشكل افقي
تصحيح الكود

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


الملف مرفق
 
 
  Dict_Code.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(28.776) KB


25-05-2020 06:52 صباحا
مشاهدة مشاركة منفردة [2]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مشكلة ظهور رسالة عند نسخ البيانات بشكل افقي
الكود تم وضعه  ليحذف الصف المكرر  كاملاً       أي   اذا تكرر كامل  الصف( 5 خلايا)
  هذا ما فهمته أنا 
اذا كنت تريد شيئاٍ اخر قم بالتوضيح

25-05-2020 07:46 صباحا
مشاهدة مشاركة منفردة [3]
المبتدأ
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس : ذكر
تاريخ الميلاد : 17-8-1981
يتابعهم : 0
يتابعونه : 2
قوة السمعة : 244
 offline 
look/images/icons/i1.gif مشكلة ظهور رسالة عند نسخ البيانات بشكل افقي
 لا اريد  حدف  المكرر    يتم  ترحيل  البيانات  كاملة  سواء مكرر او  غير مكرر  بشكل  افقي   واذا  لاحظ  اول  ما  فتحت  الملف  وجدت  بيانات  فيها  انا  مشكلتي  مع  الرسالة  فقط

25-05-2020 10:28 صباحا
مشاهدة مشاركة منفردة [4]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مشكلة ظهور رسالة عند نسخ البيانات بشكل افقي
تم معالجة الأمر

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


الملف مرفق
 
 
  Working With Dict.xlsm   تحميل xlsm مرات التحميل :(3)
الحجم :(29.753) KB


25-05-2020 10:53 صباحا
مشاهدة مشاركة منفردة [5]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif مشكلة ظهور رسالة عند نسخ البيانات بشكل افقي
خطأ بسيط في الكود تمت معالجته

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


المملف من جديد
 
 
 
  Working With_ Dict.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(30.234) KB


25-05-2020 11:04 صباحا
مشاهدة مشاركة منفردة [6]
المبتدأ
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 28-01-2018
رقم العضوية : 4055
المشاركات : 299
الجنس : ذكر
تاريخ الميلاد : 17-8-1981
يتابعهم : 0
يتابعونه : 2
قوة السمعة : 244
 offline 
look/images/icons/i1.gif مشكلة ظهور رسالة عند نسخ البيانات بشكل افقي
اعذرني  استاد  سليم   لا يرحل  بيانات  bb ويقوم   بوضع  aa  مكانها 


الصفحة 1 من 2 < 1 2 > الأخيرة »


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


 










اخلاء مسئولية: يخلى منتدى أكاديمية الصقر للتدريب مسئوليته عن اى مواضيع او مشاركات تندرج داخل الموقع ويحثكم على التواصل معنا ان كانت هناك اى إنتهاكات تتضمن اى انتهاك لحقوق الملكية الفكرية او الادبية لاى جهة - بالتواصل معنا من خلال نموذج مراسلة الإدارة .وسيتم اتخاذ الاجراءات اللازمة.
سياسة النشر: التعليقات المنشورة لا تعبر عن رأي منتدى أكاديمية الصقر للتدريب ولا نتحمل أي مسؤولية قانونية حيال ذلك ويتحمل كاتبها مسؤولية النشر.

الساعة الآن 07:43 مساء