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

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


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





احتاج كود ترحيل مبلغ الى عدد 7 شيتات

السادة الاخوة اصدقائى الافاضل , كل الاحترام من القلب لدى عدد 7 شيتس بكل منها عدد 19 عامود تحمل نفس الاسم .. اريد كود تر ..


موضوع مغلق


08-10-2020 11:17 مساء
abouelhassan
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-05-2020
رقم العضوية : 19295
المشاركات : 184
الجنس : ذكر
يتابعهم : 6
يتابعونه : 0
قوة السمعة : 418
 offline 

السادة الاخوة اصدقائى الافاضل , كل الاحترام من القلب

لدى عدد 7 شيتس  بكل منها عدد 19 عامود تحمل نفس الاسم .. اريد كود ترحيل المبلغ الى الشيت الذى امامه وكذلك اسم الشيت

قمت بعمل قائمة منسدلة لاختيار اسم العمود متها واسم الشيت المراد الترحيل المبلغ اليه بدأ من الشيت ص ص 

والشرح بالملف

كل الشكر والتقدير والاحترام من اخيكم
 

 
 
  ترحيل2.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(1490.618) KB



أفضل إجابة مقدمة من salim وهي:
تم عمل المطلوب وزيادة حبتين بحيث تتحدث القوائم المنسدلة مع كل تغيير في عدد الصفحات او اضافة اسماء جديدة في اي صفحة
ما عدا "go" و "tarheel"

Option Explicit
Dim T As Worksheet
Dim Act_sh As Worksheet
Dim Sh As Worksheet
Dim Lt#, X#, y#, m#, Ro#
Dim Rg As Range, Where As Range
Dim D_name As Object
Dim ar(), itm
'++++++++++++++++++++++++++++++++
Sub fil_data_val()
Set T = Sheets("tarheel")

Lt = T.Cells(Rows.Count, 1).End(3).Row
Set D_name = CreateObject("Scripting.Dictionary")
For Each Sh In Sheets
    If Sh.Name = "tarheel" Or Sh.Name = "go" Then
    Else
        ReDim Preserve ar(m)
        ar(m) = Sh.Name
        m = m + 1
    End If
Next
    With T.Range("C2:C" & Lt).Validation
    .Delete
    .Add 3, Formula1:=Join(ar, ",")
    End With
 For Each itm In ar
  m = Sheets(itm).Cells(2, Columns.Count).End(1).Column
   For X = 3 To m
   If Sheets(itm).Cells(2, X) <> vbNullString Then
    D_name(Sheets(itm).Cells(2, X).Value) = vbNullString
   End If
   Next X
 Next itm
 
 With T.Range("B2:B" & Lt).Validation
 .Delete
 .Add 3, Formula1:=Join(D_name.keys, ",")
 End With
 
 Erase ar: Set D_name = Nothing
End Sub
'+++++++++++++++++++++++++++++++++++++++++
Sub fil_data()
Set T = Sheets("tarheel")
Lt = T.Cells(Rows.Count, 1).End(3).Row
 For m = 2 To Lt
  If T.Range("B" & m) <> "" Then
  Set Act_sh = Sheets(T.Range("C" & m) & "")
  Set Where = Act_sh.Range("D2:AA2")
  Set Rg = Where.Find(T.Range("B" & m), lookat:=1)
   If Not Rg Is Nothing Then
    y = Rg.Column
    Ro = Act_sh.Cells(Rows.Count, y).End(3).Row + 1
    Act_sh.Cells(Ro, y) = T.Range("A" & m)
   End If
   End If
   If Act_sh.Cells(Ro, 1) = vbNullString Then
    Act_sh.Cells(Ro, 1) = Format(Date, "d - m - yyyy")
    Act_sh.Columns(1).AutoFit
   End If
 Next m
   
End Sub


الملف مرفق
عرض الإجابة




09-10-2020 01:23 صباحا
مشاهدة مشاركة منفردة [1]
ali mohamed ali
مشرف على منتدى الاكسيل
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2017
رقم العضوية : 1757
المشاركات : 1769
الدولة : مصر
الجنس : ذكر
الدعوات : 2
يتابعهم : 0
يتابعونه : 68
قوة السمعة : 9642
عدد الإجابات: 47
 offline 
look/images/icons/i1.gif احتاج كود ترحيل مبلغ الى عدد 7 شيتات
يمكنك استخدام هذه المعادلة
=IFERROR(LOOKUP(1,0/(tarheel!$C$2:$C$200=$C$1)/(tarheel!$B$2:$B$200=E$2),tarheel!$A$2:$A$200),"")

لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  ترحيل3.xlsm   تحميل xlsm مرات التحميل :(2)
الحجم :(1467.072) KB

توقيع :ali mohamed ali
{ وَقُل رَّبِّ زِدْنِي عِلْمًا }
[ كن على يقين من اعمالنا نخطئ ومن اخطائنا نتعلم ولذلك لا شي مستحيل ]
ساهم دائماً فى حل أى مشكلة او أستفسار لديك مع إضافة رد بشكره
أو دعوة لمن قدم اليك المساعدة,فالجميع هنا يعمل على مساعدة
 الاخرين لوجه الله وان تحتسب له اجر عند الله

09-10-2020 08:09 صباحا
مشاهدة مشاركة منفردة [2]
salim
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 853
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
يتابعهم : 13
يتابعونه : 33
قوة السمعة : 6607
عدد الإجابات: 67
 offline 
look/images/icons/i1.gif احتاج كود ترحيل مبلغ الى عدد 7 شيتات
تم عمل المطلوب وزيادة حبتين بحيث تتحدث القوائم المنسدلة مع كل تغيير في عدد الصفحات او اضافة اسماء جديدة في اي صفحة
ما عدا "go" و "tarheel"

Option Explicit
Dim T As Worksheet
Dim Act_sh As Worksheet
Dim Sh As Worksheet
Dim Lt#, X#, y#, m#, Ro#
Dim Rg As Range, Where As Range
Dim D_name As Object
Dim ar(), itm
'++++++++++++++++++++++++++++++++
Sub fil_data_val()
Set T = Sheets("tarheel")

Lt = T.Cells(Rows.Count, 1).End(3).Row
Set D_name = CreateObject("Scripting.Dictionary")
For Each Sh In Sheets
    If Sh.Name = "tarheel" Or Sh.Name = "go" Then
    Else
        ReDim Preserve ar(m)
        ar(m) = Sh.Name
        m = m + 1
    End If
Next
    With T.Range("C2:C" & Lt).Validation
    .Delete
    .Add 3, Formula1:=Join(ar, ",")
    End With
 For Each itm In ar
  m = Sheets(itm).Cells(2, Columns.Count).End(1).Column
   For X = 3 To m
   If Sheets(itm).Cells(2, X) <> vbNullString Then
    D_name(Sheets(itm).Cells(2, X).Value) = vbNullString
   End If
   Next X
 Next itm
 
 With T.Range("B2:B" & Lt).Validation
 .Delete
 .Add 3, Formula1:=Join(D_name.keys, ",")
 End With
 
 Erase ar: Set D_name = Nothing
End Sub
'+++++++++++++++++++++++++++++++++++++++++
Sub fil_data()
Set T = Sheets("tarheel")
Lt = T.Cells(Rows.Count, 1).End(3).Row
 For m = 2 To Lt
  If T.Range("B" & m) <> "" Then
  Set Act_sh = Sheets(T.Range("C" & m) & "")
  Set Where = Act_sh.Range("D2:AA2")
  Set Rg = Where.Find(T.Range("B" & m), lookat:=1)
   If Not Rg Is Nothing Then
    y = Rg.Column
    Ro = Act_sh.Cells(Rows.Count, y).End(3).Row + 1
    Act_sh.Cells(Ro, y) = T.Range("A" & m)
   End If
   End If
   If Act_sh.Cells(Ro, 1) = vbNullString Then
    Act_sh.Cells(Ro, 1) = Format(Date, "d - m - yyyy")
    Act_sh.Columns(1).AutoFit
   End If
 Next m
   
End Sub


الملف مرفق
 
 
  Abou_Hasan_sheets.xlsm   تحميل xlsm مرات التحميل :(5)
الحجم :(1469.994) KB


09-10-2020 09:27 صباحا
مشاهدة مشاركة منفردة [3]
abouelhassan
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-05-2020
رقم العضوية : 19295
المشاركات : 184
الجنس : ذكر
يتابعهم : 6
يتابعونه : 0
قوة السمعة : 418
 offline 
look/images/icons/i1.gif احتاج كود ترحيل مبلغ الى عدد 7 شيتات
بارك الله فيك استاذ  ali mohamed ali
مشكور جداااااااااااااااا حفظك الله
استاذى والله  salim حفظك الله
هذا هو المطلوب تمام والاضافة غاية فى الروعة  مش عارف اشكرك اد ايه والله
نصركم الله اهل لبنان اللهم امين وزادك الله من نعمه وفضله
عند الضغط على تحديث القوائم ظهر هذا الخطأ وتوقف الكود عند هذا السطر
  m = Sheets(itm).Cells(2, Columns.Count).End(1).Column

شكروتقدير واحترام من اخيك

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

تأكد ان الصف رقم 2 في الشيت Itm  غير فارغ

09-10-2020 10:19 مساء
مشاهدة مشاركة منفردة [5]
abouelhassan
عضو فعال
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-05-2020
رقم العضوية : 19295
المشاركات : 184
الجنس : ذكر
يتابعهم : 6
يتابعونه : 0
قوة السمعة : 418
 offline 
look/images/icons/i1.gif احتاج كود ترحيل مبلغ الى عدد 7 شيتات
الله يرزقك كل خير اللهم امين
بارك الله فيك استاذى الحبيب
كله تمام بارك الله فيك



الكلمات الدلالية
احتاج ، ترحيل ، مبلغ ، شيتس ،


 










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

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