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

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


اعلان هنا
صقور الاكسيل
أعلن هنا
أعلن هنا
صفحتنا على الفيس بوك
أعلن هنا


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





تعديل كود ترحيل من صفحة الى عدة صفحات

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



25-01-2020 02:34 صباحا
هانى على
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 349
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
قوة السمعة : 535
الاعجاب : 8
 offline 

السلام عليكم أساتذتى الكرام أرجو التعطف على مساعدتى فى تعديل هذا الكود

فهو يعمل بكل كفاءة ولكنى أريده عندما أقوم بإختيار صفحة معينة من الخلية C1 الموجود بها قائمة منسدلة وهذه الصفحة تكون غير موجودة بالملف مثل صفحة Basic Store عندما أضغط على Transfer يقوم الكود بفتح صفحة بهذا الإسم على نفس تنسيقات الصفحات المفتوحة مسبقا والترحيل اليها

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

Sub TransferToSpecificSheet()
    Dim Cell As Range, T As String, LR As Long, LRT As Long
    Dim WS As Worksheet, Answer As Long
        Set WS = Sheets("Main")
    LR = WS.Cells(1000, 3).End(xlUp).Row
    T = WS.Range("c1").Value
        Application.ScreenUpdating = False
            If Not IsEmpty(WS.Range("c1")) Then
                Range("b3:f" & LR).Copy
                ' Range("b3:f" & LR).Copy 'لو الترحيل من أول عمود
                With Sheets(T)
                    LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                    .Cells(LRT, 2).PasteSpecial xlPasteValues
                   ' .Cells(LRT, 1).PasteSpecial xlPasteValues  'لو اللصق من اول عمود
                End With
                            Answer = MsgBox("هل تريد ان تمسح البيانات فى ورقة 1 أم لا ؟", vbYesNo + vbQuestion)
                If Answer = vbYes Then
                    Sheets("Main").Activate
                    Sheets("Main").Range("b3:d1000,f3:f1000").Select
                    Selection.ClearContents
                Else: End If
            Else
                MsgBox "الخلية المحددة فارغة لذا لا يتم تنفيذ الكود": Exit Sub
                    End If
            Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub



لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب

 
 
  Supplier.xlsm   تحميل xlsm مرات التحميل :(10)
الحجم :(87.886) KB





25-01-2020 08:20 مساء
مشاهدة مشاركة منفردة [1]
ابراهيم الحداد
menu_open
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 166
الجنس : ذكر
الدعوات : 1
قوة السمعة : 1395
الاعجاب : 20
 offline 
look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
السلام عليكم ورحمة الله
استخدم هذا الكود و لا تمسح او تلغى الكود القديم
Sub Transfer2()
Dim ws As Worksheet, Sh As Worksheet
Dim ShName As String
Set ws = Sheets("Main")
ShName = ws.Range("C1").Value
On Error Resume Next
For Each Sh In ThisWorkbook.Worksheets
If Sh.Name <> ShName Then
Sheets.Add(after:=Sheets(Sheets.Count)).Name = ShName
Sheets(ShName).DisplayRightToLeft = False
Else
Call TransferToSpecificSheet
Exit Sub
End If
Exit For
Next
ws.Range("A2:F90").Copy
Sheets(ShName).Select
Sheets(ShName).Range("A1").Select
ActiveCell.PasteSpecial xlPasteAll
Selection.Columns.ShrinkToFit = True
Application.CutCopyMode = False
End Sub

أثارت هذه المشاركة إعجاب: عبدالله فتحى،



25-01-2020 09:26 مساء
مشاهدة مشاركة منفردة [2]
هانى على
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 349
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
قوة السمعة : 535
الاعجاب : 8
 offline 
look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
أحسنت استاذ ابراهيم بارك الله فيك وزادك الله من فضله-نعم تم المطلوب بعد فضل ربنا على يد حضرتك
ولكن عندى مشكلة عندما تم الترحيل اعطانى خطأ بالعمود E فى الصفحة المرحلة الجديدة وهو عمود Amount ( المبلغ) لأنه كان يحتوى على معادلة بصفحة Main
فقد تم استبدال هذا السطر من الكود

ActiveCell.PasteSpecial xlPasteAll

بهذان السطران
ActiveCell.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
ActiveCell.PasteSpecial Paste:=xlPasteValues


 




27-01-2020 10:21 مساء
مشاهدة مشاركة منفردة [3]
هانى على
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 349
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
قوة السمعة : 535
الاعجاب : 8
 offline 
look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
السلام عليكم استاذ ابراهيم
ارجو تقبل اعتذارى .... فقد حدث معى خلل عند تنفيذ الكود وعمل الترحيل فهو كلما قمت بعمل ترحيل جديد الى صفحة مفتوحة وقائمة بالفعل يتم حذف البيانات السابق ترحيلها وفقط يتم ترحيل البيانات الجديدة , كما يقوم ايضا بفتح شيت جديد بالملف غير اسم الصفحة الموجودة سابقا
فكما تعلم انه من الضرورى عدم حذف البيانات المرحلة سابقا والإحتفاظ بها فى الصفحة المرحل اليها بناءا على اسم الصفحة
لو هناك امكانية استاذى الكريم فى التعديل على الكود حتى لا يقوم بحذف البيانات المرحلة سابقا فى الصفحات المختلفة وعدم اضافة صفحات غير مرغوب فيها
بارك الله فيك وزادك الله من فضله
 




28-01-2020 12:43 صباحا
مشاهدة مشاركة منفردة [4]
ابراهيم الحداد
menu_open
خبير
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 166
الجنس : ذكر
الدعوات : 1
قوة السمعة : 1395
الاعجاب : 20
 offline 
look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
السلام عليكم ورحمة الله
لقد تم دمج الكودين فى كود واحد
Sub TransferToSpecificSheet()
    Dim Cell As Range, T As String, LR As Long, LRT As Long
    Dim ws As Worksheet, Sh As Worksheet, Answer As Long
        Set ws = Sheets("Main")
    LR = ws.Cells(1000, 3).End(xlUp).Row
    T = ws.Range("c1").Value
        Application.ScreenUpdating = False
        If Not IsEmpty(ws.Range("c1")) Then
For i = 1 To Worksheets.Count
If Worksheets(i).Name = T Then
  exists = True
  End If
  Next i
  If Not exists Then
  Worksheets.Add(after:=Sheets(Sheets.Count)).Name = T
  ws.Range("A2:F2").Copy
 With Sheets(T)
 .Range("A1").Select
 .Range("A1").PasteSpecial xlPasteFormats
 .Range("A1").PasteSpecial xlPasteValues
  .DisplayRightToLeft = False
 End With
  End If
                
        ws.Range("b3:f" & LR).Copy
        With Sheets(T)
            LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
            .Cells(LRT, 2).PasteSpecial xlPasteValues
            .Cells(LRT, 2).PasteSpecial xlPasteFormats
            .Columns("A:F").ShrinkToFit = True
        End With
          Else
          MsgBox "الخلية المحددة فارغة لذا لا يتم تنفيذ الكود": Exit Sub
          Exit Sub
          End If
                              
                Answer = MsgBox("هل تريد ان تمسح البيانات فى ورقة 1 أم لا ؟", vbYesNo + vbQuestion)
                If Answer = vbYes Then
                Sheets("Main").Activate
                Sheets("Main").Range("b3:d1000,f3:f1000").Select
         Else
         End If
                                      
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub




28-01-2020 08:24 مساء
مشاهدة مشاركة منفردة [5]
هانى على
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 349
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
قوة السمعة : 535
الاعجاب : 8
 offline 
look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
بارك الله فيك استاذ ابراهيم وجزاك الله خير الثواب
هو بالفعل المطلوب جعله الله فى ميزان حسناتك




28-01-2020 10:00 مساء
مشاهدة مشاركة منفردة [6]
salim
menu_open
خبير معتمد
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 22-08-2017
رقم العضوية : 43
المشاركات : 498
الجنس : ذكر
تاريخ الميلاد : 1-5-1989
الدعوات : 1
قوة السمعة : 3836
الاعجاب : 75
 offline 
look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
جرب هذا الكود

Sub TransferToSpecificSheet()
    Dim Cell As Range, t As String, LR As Long, LRT As Long
    Dim WS As Worksheet, Answer As Long, Bol As Boolean
        Set WS = Sheets("Main")
    LR = WS.Cells(1000, 3).End(xlUp).Row
    t = WS.Range("c1").Value
        Application.ScreenUpdating = False
      If Not IsEmpty(WS.Range("c1")) Then
   
      Bol = Evaluate("=ISREF(" & "'" & WS.Range("c1") & "'!A1)")

  If Not Bol Then
    Sheets.Add(, after:=Sheets(Sheets.Count)).Name = WS.Range("c1")
    WS.Range("A2:f" & LR).Copy
      With ActiveSheet
      .Range("a1").PasteSpecial (xlPasteValuesAndNumberFormats)
      .Range("a1").PasteSpecial (xlPasteColumnWidths)
      .Range("a1").PasteSpecial (xlPasteFormats)
      .DisplayRightToLeft = False
      End With
      WS.Select
     GoTo End_me
  End If
                WS.Range("A3:f" & LR).Copy
                With Sheets(t)
                    LRT = .Cells(Rows.Count, 3).End(xlUp).Row + 1
                      With .Cells(LRT, 1)
                      .PasteSpecial (xlPasteValuesAndNumberFormats)
                      .PasteSpecial (xlPasteColumnWidths)
                      .PasteSpecial (xlPasteFormats)
                      End With
                End With
      Answer = MsgBox("هل تريد ان تمسح البيانات فى ورقة 1 أم لا ؟", vbYesNo + vbQuestion)
                If Answer = vbYes Then
                    Sheets("Main").Activate
                    Sheets("Main").Range("b3:d1000,f3:f1000").Select
                    Selection.ClearContents
                Else: End If
            Else
' MsgBox "الخلية المحددة فارغة لذا لا يتم تنفيذ الكود": Exit Sub
                    End If
End_me:
            Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub


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


أثارت هذه المشاركة إعجاب: عبدالله فتحى،



28-01-2020 10:28 مساء
مشاهدة مشاركة منفردة [7]
هانى على
menu_open
عضو ماسي
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 10-03-2018
رقم العضوية : 4794
المشاركات : 349
الجنس : ذكر
تاريخ الميلاد : 1-4-1980
قوة السمعة : 535
الاعجاب : 8
 offline 
look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
أحسنت استاذ سليم كود ممتاز وسريع
دائما مبدع بارك الله فيك وزادك الله من فضله
وجزاكم الله جميعا اساتذتى الكرام كل خير

أثارت هذه المشاركة إعجاب: عبدالله فتحى،





المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
توقف عمل كود الترحيل وكذلك توقف كود طباعه الجزء المحدد في حال كانت الصفحة محمية ابو طيبه
1 39 ابو طيبه
ترحيل خلايا متفرفه عبر مصفوفة هاوي برمجه
3 76 YasserKhalil
تعديل على كود الترحيل واستدعاء بيانات من شيت لاخر وعمل قائمة منسدله ابو طيبه
14 549 ابو طيبه
المطلوب ترحيل من شيت الى اخر بموجب قيمة خلية رمزي المسقف
4 134 YasserKhalil
الترحيل وفقا لتاريخ اليوم أبو سجده
7 219 YasserKhalil

الكلمات الدلالية
تعديل ، ترحيل ، صفحة ، صفحات ،


 







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

الساعة الآن 07:00 صباحا

أعلن هنا
أعلن هنا
أعلن هنا