logo

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



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





25-01-2020 02:34 صباحاً

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


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


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

CODE
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 مرات التحميل :(11)
الحجم :(87.886) KB





look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
  25-01-2020 08:20 مساءً   [1]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 226
الجنس :
الدعوات : 4
قوة السمعة : 2147
الاعجاب : 19
السلام عليكم ورحمة الله
استخدم هذا الكود و لا تمسح او تلغى الكود القديم
CODE
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

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



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

ActiveCell.PasteSpecial xlPasteAll


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




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




look/images/icons/i1.gif تعديل كود ترحيل من صفحة الى عدة صفحات
  28-01-2020 12:43 صباحاً   [4]
معلومات الكاتب ▼
تاريخ الإنضمام : 26-08-2017
رقم العضوية : 163
المشاركات : 226
الجنس :
الدعوات : 4
قوة السمعة : 2147
الاعجاب : 19
السلام عليكم ورحمة الله
لقد تم دمج الكودين فى كود واحد
CODE
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




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




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

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 مرات التحميل :(10)
الحجم :(102.897) KB


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



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

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



اضافة رد جديد اضافة موضوع جديد



المواضيع المتشابهه
عنوان الموضوع الكاتب الردود الزوار آخر رد
محتاج كودترحيل saad mohamed
0 22 saad mohamed
تموذج ترحيل وبحث وتعديل على البيانات مالك ماريه
147 11813 sharawee707
ترحيل بيانات من خلايا مختلفه من ملفات الى ملف واحد مع كتابة الملاحظات التى تخص ترحيل البيانات Lotfy
7 225 YasserKhalil
فورم ترحيل ايات القران الكريم من التكست بوكس الى خلية الاكسل باى عدد من الكلمات مجدى يونس
2 157 مجدى يونس
ترحيل كل بيانات الموظفين الى شيتات مستقلة Redha
1 233 Redha

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









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

الساعة الآن 12:58 AM