كود ترحيل من صفحة لأخرى بدون تكرار

**مهند محسن** · سبتمبر 1, 2019

السلام عليكم اساتذتى واحبائى الكرام-ارجو التعطف والتكرم على مساعدتى في إيجاد كود يقوم بترحيل البيانات من صفحة Data الى صفحة Moda Show وذلك بدون تكرار اسم الفندق في نفس التاريخ وتجميع عدد الأفراد في هذا الفندق كما بالنتائج الموجودة بصفحة Moda Show وبحيث لو اجتمع مندوبين في نفس الفندق خلال نفس اليوم فلابد من ترحيلهم هما الإثنين لهذا الفندق ويكون بينهما علامة + كما بالمثال المرفق

اتمن ان يكون المطلوب واضح للأساتذة ,ولكم منى جزيل الشكر وبارك الله فيكم جميعا

Moda Show Sales 2019.xlsm

تم تعديل سبتمبر 1, 2019 بواسطه مهند محسن

**سليم حاصبيا** · سبتمبر 1, 2019

جرب هذا الكود

Option Explicit

Sub Give_data()
Dim Dict As Object
Dim Itm, i%: i = 2
Dim K, Ky, xx%: xx = 3
Dim SA As Worksheet: Set SA = Sheets("Salim")
Dim DA As Worksheet: Set DA = Sheets("data")


Set Dict = CreateObject("SCRIPTING.DICTIONARY")
   SA.Range("A2").CurrentRegion.Offset(1).ClearContents
   
   Do Until DA.Range("G" & i) = vbNullString
       K = DA.Range("G" & i): Itm = DA.Range("L" & i)
      If Not Dict.Exists(K) Then
       Dict.Add K, Itm
      Else
       Dict(K) = Dict(K) & "," & Itm
      End If
      i = i + 1
   Loop
   
   SA.Range("A3").Resize(Dict.Count) = _
   Application.Transpose(Dict.keys)
 
  For Each Ky In Dict.keys
   SA.Cells(xx, 3) = Join(Split(Dict(Ky), ","), ",")
   xx = xx + 1
  Next
        Dict.RemoveAll: i = 2: xx = 3

Do Until DA.Range("G" & i) = vbNullString
       K = DA.Range("G" & i): Itm = DA.Range("H" & i)
      If Not Dict.Exists(K) Then
       Dict.Add K, Itm
       Else
        Dict(K) = Dict(K) & "," & Itm
       End If
      i = i + 1
 Loop
 
   For Each Ky In Dict.keys
   SA.Cells(xx, 4) = Join(Split(Dict(Ky), ","), ",")
    xx = xx + 1
   Next
   Dict.RemoveAll: Set Dict = Nothing
End Sub

الملف مرفق

Show Sales_salim_ 2019.xlsm

**مهند محسن** · سبتمبر 1, 2019

بارك الله فيك استاذى الكريم سليم كود ممتاز ورائع

ولكنى استاذى الكريم اريد جلب اسم الفندق خلال اليوم الواحد كل فندق مختلف في صف لوحده ولا اريد دمجهم في صف واحد وذلك كما بالصورة

كما انى لا أريد مسح البيانات التي تم ترحيلها مسبقا الى صفحة Salim عندما يتم مسح البيانات الموجودة بصفحة Data ,لأنه يوميا يتم محو البيانات الموجودة بصفحة Data ولصق بيانات جديدة مأخوذة من برنامج الشركة فلابد ان يكون الترحيل متتابع ومتتالى للترحيل القديم او من الأفضل محو البيانات الموجودة بصفحة Data عند الترحيل

جزاك الله كل خير واسف استاذى الكريم على ازعاج حضرتك

تم تعديل سبتمبر 1, 2019 بواسطه مهند محسن

**سليم حاصبيا** · سبتمبر 1, 2019

تم التعديل على الماكرو (فقط للفنادق ) اما الباقي فيما بعد لضيق الوقت

Option Explicit

Sub Give_data1()
Rem =====>>> Created By Salim Hasbaya On 1/9/2019
Dim Dict As Object
Dim st, ff%
Dim Ro%, x%, t%, arr
Dim Itm, i%: i = 2
Dim K, Ky, xx% ': xx = 3
Dim SA As Worksheet: Set SA = Sheets("Salim")
Dim DA As Worksheet: Set DA = Sheets("data")
Dim My_col As New Collection
Dim My_col2 As New Collection

     'For remove the Contents Of the sheet "Salim" Please remove _
     the "'" from the next line
'SA.Range("a3").Resize(10000, 5).ClearContents

 xx = SA.Cells(Rows.Count, "c").End(3).Row
 xx = IIf(xx = 2, 3, xx + 2)

Set Dict = CreateObject("SCRIPTING.DICTIONARY")
 Ro = DA.Cells(Rows.Count, "G").End(3).Row
  For i = 2 To Ro
   On Error Resume Next
    My_col.Add CDate(DA.Range("G" & i).Value), CLng(DA.Range("G" & i).Value) & " "
    Next
  For i = 1 To My_col.Count
        For x = 2 To Ro
          If DA.Cells(x, "G") = My_col(i) Then
              K = DA.Cells(x, "L")
                 Itm = Application.CountIf(DA.Range("L2:L" & x), DA.Range("L" & x))
                 If Not Dict.Exists(My_col(i)) And Itm = 1 Then
                   Dict.Add My_col(i), K
                 Else
                    Dict(My_col(i)) = Dict(My_col(i)) & "," & K
                 End If
          End If
        Next x
   SA.Range("A" & xx) = My_col(i)
    For Each Ky In Dict.keys
       arr = Split(Dict(Ky), ",")
            For ff = 0 To UBound(arr)
             On Error Resume Next
             My_col2.Add arr(ff), arr(ff)
            Next ff
        If My_col2(1) = "" Then My_col2.Remove (1)
         On Error GoTo 0
         Erase arr
            ReDim arr(1 To My_col2.Count)
              For ff = 1 To My_col2.Count
               arr(ff) = My_col2(ff)
              Next ff
                t = UBound(arr)
             If t >= 1 Then
              SA.Cells(xx, 3).Resize(UBound(arr) - LBound(arr) + 1) = _
              Application.Transpose(arr)
            End If
            xx = SA.Cells(Rows.Count, "c").End(3).Row + 2
            Dict.RemoveAll: Erase arr: Set My_col2 = New Collection
    Next Ky
   Next
     'For remove the Contents Of the sheet "Data" Please remove _
     the "'" from the next line
  'kiLL_data
  Dict.RemoveAll: Erase arr: Set My_col2 = Nothing
  Set My_col = Nothing: Set SA = Nothing: Set DA = Nothing
End Sub
'++++++++++++++++++++++++++++++++++++++
Sub kiLL_data()
Sheets("Data").Range("a2", Range("L1").End(4)).ClearContents
End Sub

الملف مرفق

Show Sales_salim_ 2019_new.xlsm

**مهند محسن** · سبتمبر 1, 2019

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

**سليم حاصبيا** · سبتمبر 1, 2019

استبدل حرف الـــ E بحرف الـــ L في الماكرو

**مهند محسن** · سبتمبر 1, 2019

بارك الله فيك استاذى الكريم كده تمام

ولكن يبقى ياريت يمكن جلب ايضا اسم المندوب وعدد الزبائن واريد ايضا بعد اذن حضرتك ان يتكرر التاريخ طالما هناك اكثر من فندق فى التاريخ الواحد

**سليم حاصبيا** · سبتمبر 1, 2019

تم معالجة الامر (سم المندوب) وهذه المرة بـــ معادلة بسيطة تم ادراجها في نفس الكود (ولا لزوم لتكرار التاريخ حيث ان البيانات بين تاريخ واخر بفصلها صف فارغ)

الكود الجديد

Option Explicit

Sub Give_data1()
Rem =====>>> Created By Salim Hasbaya On 1/9/2019
Dim Dict As Object
Dim st, ff%
Dim Ro%, x%, t%, arr
Dim Itm, i%: i = 2
Dim K, Ky, xx% ': xx = 3
Dim SA As Worksheet: Set SA = Sheets("Salim")
Dim DA As Worksheet: Set DA = Sheets("data")
Dim My_col As New Collection
Dim My_col2 As New Collection

     'For remove the Contents Of the sheet "Salim" Please remove _
     the "'" from the next line
'SA.Range("a3").Resize(10000, 5).ClearContents

 xx = SA.Cells(Rows.Count, "c").End(3).Row
 xx = IIf(xx = 2, 3, xx + 2)

Set Dict = CreateObject("SCRIPTING.DICTIONARY")
 Ro = DA.Cells(Rows.Count, "G").End(3).Row
  For i = 2 To Ro
   On Error Resume Next
    My_col.Add CDate(DA.Range("G" & i).Value), CLng(DA.Range("G" & i).Value) & " "
    Next
  For i = 1 To My_col.Count
        For x = 2 To Ro
          If DA.Cells(x, "G") = My_col(i) Then
              K = DA.Cells(x, "L")
                 Itm = Application.CountIf(DA.Range("E2:L" & x), DA.Range("L" & x))
                 If Not Dict.Exists(My_col(i)) And Itm = 1 Then
                   Dict.Add My_col(i), K
                 Else
                    Dict(My_col(i)) = Dict(My_col(i)) & "," & K
                 End If
          End If
        Next x
   SA.Range("A" & xx) = My_col(i)
    For Each Ky In Dict.keys
       arr = Split(Dict(Ky), ",")
            For ff = 0 To UBound(arr)
             On Error Resume Next
             My_col2.Add arr(ff), arr(ff)
            Next ff
        If My_col2(1) = "" Then My_col2.Remove (1)
         On Error GoTo 0
         Erase arr
            ReDim arr(1 To My_col2.Count)
              For ff = 1 To My_col2.Count
               arr(ff) = My_col2(ff)
              Next ff
                t = UBound(arr)
             If t >= 1 Then
              SA.Cells(xx, 3).Resize(UBound(arr) - LBound(arr) + 1) = _
              Application.Transpose(arr)
            End If
            xx = SA.Cells(Rows.Count, "c").End(3).Row + 2
            Dict.RemoveAll: Erase arr: Set My_col2 = New Collection
    Next Ky
   Next
     'For remove the Contents Of the sheet "Data" Please remove _
     the "'" from the next line
  'kiLL_data
  With SA.Range("d3").Resize(xx - 2)
  .Formula = "=IF(c3="""","""",INDEX(Data!$H$2:$H$500,MATCH($C3,Data!$L$2:$L$500,0)))"
  .Value = .Value
  End With
  Dict.RemoveAll: Erase arr: Set My_col2 = Nothing
  Set My_col = Nothing: Set SA = Nothing: Set DA = Nothing
End Sub
'++++++++++++++++++++++++++++++++++++++
Sub kiLL_data()
Sheets("Data").Range("a2", Range("L1").End(4)).ClearContents
End Sub

الملف من جديد

Show Sales_salim_ 2019_Super.xlsm

**سليم حاصبيا** · سبتمبر 1, 2019

ملاحظة اخيرة

**مهند محسن** · سبتمبر 1, 2019

بارك الله فيك اخى الكريم بعد تنفيذ هذه الخطوة لا يقوم بالإزالة وتظهر هذه الرسالة

كما انى اريد عند وجود اسمين مختلفين للمندوبين على فندق واحد فى نفس التاريخ , يعمل الكود على جلبهما لنفس الفندق وبينهما علامة +

**سليم حاصبيا** · سبتمبر 1, 2019

طبعاً سيحدث معك خطأ لانك بهده الخطوة (KiLL_data) قد حذفت البيانات من الشيت Data

بانتظار تعبئة بيانات جديدة (حسب طلبك في مشاركة سابقة)

واذا لم ترغب بحذف البيانات من الشيت Data قم باعادة الفاصلة الى جانب الكلمة KiLL_data

**مهند محسن** · سبتمبر 3, 2019

أستاذى الكريم سليم كده تمام

ولكن يبقى جلب الأعداد وجلب أسماء المندوبين اذا كان هناك اكثر من مندوب مشترك في فندق واحد في نفس اليوم

جزاك الله كل خير

**سليم حاصبيا** · سبتمبر 3, 2019

بالنسبة للمناديب

جرب هذا الكود بشكل منفرد مبدياً (يمكن التعدل عليه اذا كان غير مناسب و من ثم اضافته الى الكود الاساسي)

الزر Mandoub

لم افهم عن اي اعدادالتي يجب جمعها تتكلم

Option Explicit

Sub man_doub()

 Dim LA_SALIM%, LG_data%
 Dim my_RgA As Range, my_RgG As Range
 Dim i%, k%, st$
  
  LA_SALIM = Sheets("SALIM").Cells(Rows.Count, "A").End(3).Row
  LG_data = Sheets("data").Cells(Rows.Count, "G").End(3).Row
  Sheets("SALIM").Range("E3").Resize(1000).ClearContents
  
  If LA_SALIM = 2 Then Exit Sub
  If LG_data = 1 Then Exit Sub
  Sheets("data").Range("Al2").Resize(500).Formula = _
  "=IF(H2="""","""",SUMPRODUCT(--(H2&G2=$H$2:$H2&$G$2:$G2)))"
  Set my_RgA = Sheets("SALIM").Range("a3:a" & LA_SALIM)
  Set my_RgG = Sheets("data").Range("G2:G" & LG_data)
 
 
 For i = 3 To LA_SALIM
   If Sheets("SALIM").Cells(i, 1) = vbNullString Then GoTo Next_i
   For k = 2 To LG_data
     If Sheets("data").Cells(k, "G") = vbNullString Then GoTo Next_K
       If Sheets("SALIM").Cells(i, 1) = Sheets("data").Cells(k, "G") _
             And Sheets("data").Cells(k, "AL") = 1 Then
             st = st & Sheets("data").Cells(k, "H") & "+"
      End If
Next_K:
  Next k

If Len(st) > 0 Then
     Sheets("SALIM").Cells(i, 5) = _
     Mid(st, 1, Len(st) - 1)
  End If
    st = ""
Next_i:
 Next i
Sheets("data").Range("AL2").Resize(500).ClearContents
End Sub

الملف مرفق

Show Sales_salim_Mandob.xlsm

**مهند محسن** · سبتمبر 3, 2019

أعتذر واتأسف من حضرتك استاذى الكريم على كل هذا التعب والمجهود الممتاز - ولكنى اريد جمع المناديب ذات الفندق الواحد خلال نفس اليوم

والأعداد الواجب جمعها هي الموجودة بالعمود Aالأول من صفحة Data

تم تعديل سبتمبر 3, 2019 بواسطه مهند محسن

**مهند محسن** · سبتمبر 5, 2019

هل هناك حل اساتذتى الكرام لهذا الأمر ؟

بارك الله فيكم

تسجيل الدخول

كود ترحيل من صفحة لأخرى بدون تكرار

الردود الموصى بها

مهند محسن

سليم حاصبيا

مهند محسن

سليم حاصبيا

مهند محسن

سليم حاصبيا

مهند محسن

سليم حاصبيا

سليم حاصبيا

مهند محسن

سليم حاصبيا

مهند محسن

سليم حاصبيا

مهند محسن

مهند محسن

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information