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

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


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





مساعدة في كود يقوم بالترحيل وعمل نسخة احتياطية

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


موضوع مغلق

الصفحة 1 من 2 < 1 2 > الأخيرة »


20-10-2020 05:25 مساء
ابااسماعيل
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 29-10-2018
رقم العضوية : 8533
المشاركات : 29
الجنس : ذكر
تاريخ الميلاد : 19-11-1980
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 43
 offline 

السلام عليكم و رحمة الله و بركاته 
في هذا الملف يوجد فيه كود ترحيل البيانات الى شيتين وعمل نسخه احتياطية للملف الكود خاص بالاخ الفاضل والمحترم  استاذ حسونة جزاه الله خيرا في مشاركة الاخ محمد عبد السلام الكود يعمل بشكل رائع لكن لدي طلب اذا كان ممكن اريد بعض التعديلات في الكود اريد اذا كانت الخانه F5 اجل يتم ترحيل البيانات  الى شيتين شيت واحد و شيت اثنان اما اذا كانت الخانه F5 نقدي يتم ترحيل البيانات الى شيت اثنان وعدم الترحيل  الى شيت واحد
لمشاهدة الروابط يلزمك التسجيل في أكاديمية الصقر للتدريب
 
 
  فاتورة(2).xlsm   تحميل xlsm مرات التحميل :(13)
الحجم :(158.213) KB



أفضل إجابة مقدمة من hassona229 وهي:
تفضل اخى احذف السطور

md = MsgBox(" هل تريد الترحيل الى Sheet1  ؟" _
, vbYesNo + vbQuestion + vbApplicationModal, "أكاديمية الصقر للتدريب")
If md = vbNo Then GoTo 80 Else

 وضع مكانهم هذا السطر

If ws.[f5].Text = "نقدي" Then GoTo 80 Else
عرض الإجابة




20-10-2020 08:49 مساء
مشاهدة مشاركة منفردة [1]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 808
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 11
قوة السمعة : 4330
عدد الإجابات: 113
 offline 
look/images/icons/i1.gif مساعدة في كود يقوم بالترحيل وعمل نسخة احتياطية
وعليكم السلام ورحمه الله وبركاته

تفضل اخى



Option Explicit
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean

Private Sub CommandButton1_Click()

    Dim wx As Workbook, ws As Worksheet, wss As Worksheet, wss2 As Worksheet, Nam, lr As Long, lr2 As Long, md As Long, da As String
    Set wx = ThisWorkbook
    Set ws = wx.Sheets("invoice")
    Set wss = wx.Sheets("sheet1")
    Set wss2 = wx.Sheets("sheet2")
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
        With ws
            Nam = .Range("e5")
            da = Format(Now(), "dd-mm-yyyy hh.mm.ss")
            MakeSureDirectoryPathExists "d:\backBackup\"
            ThisWorkbook.SaveCopyAs Filename:="d:\backBackup\" & Nam & da & ".xlsm"
            
        md = MsgBox(" هل تريد الترحيل الى Sheet1  ؟" _
        , vbYesNo + vbQuestion + vbApplicationModal, "أكاديمية الصقر للتدريب")
          If md = vbNo Then GoTo 80 Else
            '=========================================
             lr = wss.Range("a" & Rows.Count).End(xlUp).Row + 1
            If ws.[f5].Text = "اجل" Then
               
                wss.Range("a" & lr).Value = Nam
                wss.Range("a" & lr).Font.Color = 255
                wss.Range("B" & lr).Value = da
                wss.Range("C" & lr).Value = "اجل"
                Else
                wss.Range("a" & lr).Value = Nam
                wss.Range("B" & lr).Value = da
                wss.Range("C" & lr).Value = "نقدي"
            End If
80
            lr2 = wss2.Range("a" & Rows.Count).End(xlUp).Row + 1
            If ws.[f5].Text = "اجل" Then
                
                wss2.Range("a" & lr2).Value = Nam
                wss2.Range("a" & lr2).Font.Color = 255
                wss2.Range("B" & lr2).Value = da
                wss2.Range("C" & lr2).Value = "اجل"
                Else
                wss2.Range("a" & lr2).Value = Nam
                wss2.Range("B" & lr2).Value = da
                wss2.Range("C" & lr2).Value = "نقدي"
            End If
            '========================================
        End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
        MsgBox "تم حفظ نسخة باسم " & Nam & da & " ", vbInformation
End Sub


21-10-2020 06:55 صباحا
مشاهدة مشاركة منفردة [2]
YasserKhalil
مراقب عام
معلومات الكاتب ▼
تاريخ الإنضمام : 21-08-2017
رقم العضوية : 3
المشاركات : 10455
الجنس : ذكر
تاريخ الميلاد : 1-10-1978
الدعوات : 24
يتابعهم : 1
يتابعونه : 536
قوة السمعة : 36632
عدد الإجابات: 256
 offline 
look/images/icons/i1.gif مساعدة في كود يقوم بالترحيل وعمل نسخة احتياطية
بارك الله فيك أخي العزيز حسونة وجزاك الله خيراً.

21-10-2020 08:35 صباحا
مشاهدة مشاركة منفردة [3]
ابااسماعيل
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 29-10-2018
رقم العضوية : 8533
المشاركات : 29
الجنس : ذكر
تاريخ الميلاد : 19-11-1980
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 43
 offline 
look/images/icons/i1.gif مساعدة في كود يقوم بالترحيل وعمل نسخة احتياطية

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

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

لطلب اذا كانت تتوفر هذه الطريقه في المطلوب اريد ان تطبق في هذا الكود وجزاكم الله خيرا


Option Explicit
Private Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal DirPath As String) As Boolean

Private Sub CommandButton1_Click()

    Dim wx As Workbook, ws As Worksheet, wss As Worksheet, wss2 As Worksheet, Nam, lr As Long, lr2 As Long, md As Long
    Set wx = ThisWorkbook
    Set ws = wx.Sheets("invoice")
    Set wss = wx.Sheets("sheet1")
    Set wss2 = wx.Sheets("sheet2")
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
        With ws
            Nam = .Range("e5") & " " & Format(Now(), "dd-mm-yyyy  hh.mm.ss")
            MakeSureDirectoryPathExists "d:backBackup"
            ThisWorkbook.SaveCopyAs Filename:="d:backBackup" & Nam & ".xlsm"
            
        md = MsgBox(" هل تريد الترحيل الى Sheet1  ؟" _
        , vbYesNo + vbQuestion + vbApplicationModal, "أكاديمية الصقر للتدريب")
          If md = vbNo Then GoTo 80 Else
            '=========================================
            If ws.[f5].Text = "اجل" Then
                lr = wss.Range("a" & Rows.Count).End(xlUp).row + 1
                wss.Range("a" & lr).Value = Nam
                wss.Range("a" & lr).Font.Color = 255
                wss.Range("b" & lr).Value = "اجل"
                Else: wss.Range("a" & lr).Value = Nam
                wss.Range("b" & lr).Value = "نقدي"
            End If
80
            If ws.[f5].Text = "اجل" Then
                lr2 = wss2.Range("a" & Rows.Count).End(xlUp).row + 1
                wss2.Range("a" & lr2).Value = Nam
                wss2.Range("a" & lr2).Font.Color = 255
                wss2.Range("b" & lr2).Value = "اجل"
                Else: wss.Range("a" & lr2).Value = Nam
                wss2.Range("b" & lr2).Value = "نقدي"
            End If
            '========================================
        End With
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    Application.EnableEvents = True
        MsgBox "تم حفظ نسخة باسم " & Nam & " ", vbInformation
End Sub


 

21-10-2020 04:03 مساء
مشاهدة مشاركة منفردة [4]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 808
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 11
قوة السمعة : 4330
عدد الإجابات: 113
 offline 
look/images/icons/i1.gif مساعدة في كود يقوم بالترحيل وعمل نسخة احتياطية
حضرتك جربت الكود السابق الذي وضعته لك
ضعه في ملفك وقم بالتجربة
واطلعنا بالنتائج

21-10-2020 08:39 مساء
مشاهدة مشاركة منفردة [5]
ابااسماعيل
عضو مشارك
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 29-10-2018
رقم العضوية : 8533
المشاركات : 29
الجنس : ذكر
تاريخ الميلاد : 19-11-1980
يتابعهم : 0
يتابعونه : 0
قوة السمعة : 43
 offline 
look/images/icons/i1.gif مساعدة في كود يقوم بالترحيل وعمل نسخة احتياطية

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

اريد عندما تكون الخانه F5 اجل  في شيت invoice يتم ترحيل البيانات  الى شيتين شيت واحد و شيت اثنان اما اذا كانت الخانه F5 نقدي يتم ترحيل البيانات الى شيت اثنان وعدم الترحيل  الى شيت واحد

 md = MsgBox(" هل تريد الترحيل الى Sheet1  ؟" _
        , vbYesNo + vbQuestion + vbApplicationModal, "أكاديمية الصقر للتدريب")
          If md = vbNo Then GoTo 80 Else

22-10-2020 03:25 صباحا
مشاهدة مشاركة منفردة [6]
hassona229
مشرف عام
rating
معلومات الكاتب ▼
تاريخ الإنضمام : 20-11-2018
رقم العضوية : 9257
المشاركات : 808
الدولة : مصر
الجنس : ذكر
تاريخ الميلاد : 13-9-1980
يتابعهم : 0
يتابعونه : 11
قوة السمعة : 4330
عدد الإجابات: 113
 offline 
look/images/icons/i1.gif مساعدة في كود يقوم بالترحيل وعمل نسخة احتياطية
تفضل اخى احذف السطور

md = MsgBox(" هل تريد الترحيل الى Sheet1  ؟" _
, vbYesNo + vbQuestion + vbApplicationModal, "أكاديمية الصقر للتدريب")
If md = vbNo Then GoTo 80 Else

 وضع مكانهم هذا السطر

If ws.[f5].Text = "نقدي" Then GoTo 80 Else


الصفحة 1 من 2 < 1 2 > الأخيرة »


الكلمات الدلالية
بالترحيل ، يقوم ، مساعده ، نسخه ، وعمل ، احتياطيه ،


 










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

الساعة الآن 08:21 مساء