اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

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

مهند محسن

بواسطه مهند محسن
في منتدى الاكسيل Excel

 مشاركة

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

مهند محسن

مهند محسن

قام بنشر
قام بنشر (معدل)

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

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

 

 

 

Moda Show Sales 2019.xlsm

تم تعديل بواسطه مهند محسن
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

جرب هذا الكود 

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

  • Like 1
رابط هذا التعليق
شارك
مهند محسن

مهند محسن

قام بنشر
  • الكاتب
قام بنشر (معدل)

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

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

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

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

 

Untitled.png

تم تعديل بواسطه مهند محسن
رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

  • Like 1
رابط هذا التعليق
شارك
مهند محسن

مهند محسن

قام بنشر
  • الكاتب
قام بنشر

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

 

1.png

رابط هذا التعليق
شارك
مهند محسن

مهند محسن

قام بنشر
  • الكاتب
قام بنشر

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

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

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

الكود الجديد 

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

  • Like 1
رابط هذا التعليق
شارك
مهند محسن

مهند محسن

قام بنشر
  • الكاتب
قام بنشر

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

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

 

1.png

2.png

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

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

 

رابط هذا التعليق
شارك
مهند محسن

مهند محسن

قام بنشر
  • الكاتب
قام بنشر

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

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

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

رابط هذا التعليق
شارك
سليم حاصبيا

سليم حاصبيا

قام بنشر
قام بنشر

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

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

الزر 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

  • Like 1
رابط هذا التعليق
شارك
مهند محسن

مهند محسن

قام بنشر
  • الكاتب
قام بنشر (معدل)

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

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

 

Untitled.png

تم تعديل بواسطه مهند محسن
رابط هذا التعليق
شارك

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

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

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept