نسخ بكود به كلمة مرور

[ashhma79]

كل عام وانتم بخير بمناسبة رآس السنة الهجرية

مطلوب ضبط معادلة نسخ ادخال البيانات الاساسية من

مستند book2    و لصقها  إلى مستند  book1

فتح  book1  ثم الضغط على نسخ

و يوجد كلمة مرور 123 لفتح مستند  book2

مطلوب عند الضغط على نسخ اختيار book2 و الضغط موافق و ان يتم كتابة كلمة المرور فى الكود 123 لفتح البرنامج مباشرة

اضافة

Workbooks.Open (strFile), , , Password:="123"

نسخ كلمة مرور.rar

[hegazee]

و عليكم السلام

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

 

Sub Button1_Click()
    Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range
    Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String
    WSname = "إدخال بيانات أساسية"  ' تأكد من أن الاسم مطابق تمامًا
    
    On Error GoTo ErrorHandler
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    ' تحديد مسار الملف
    FilePath = ThisWorkbook.Path & "\Book2.xlsb"  ' تأكد من امتداد الملف 
    
    ' التحقق من وجود الملف
    If Dir(FilePath) = "" Then
        MsgBox "ملف Book2 غير موجود في المسار: " & vbCrLf & FilePath, vbExclamation
        Exit Sub
    End If
    
    ' فتح الملف بكلمة المرور
    Set Wb1 = Workbooks.Open(FilePath, Password:="123")  ' تأكد من كلمة المرور
    Set Wb2 = ThisWorkbook
    
    ' التحقق من وجود ورقة العمل
    Set WSdata = Wb1.Sheets(WSname)
    Set WSdest = Wb2.Sheets(WSname)
    
    If WSdata Is Nothing Or WSdest Is Nothing Then
        MsgBox "ورقة العمل '" & WSname & "' غير موجودة في أحد الملفين", vbCritical
        Wb1.Close False
        Exit Sub
    End If
    
    ' نسخ البيانات
    Set OnRng = WSdata.UsedRange
    If OnRng.Cells.CountLarge = 1 And IsEmpty(OnRng.Value) Then
        MsgBox "لا توجد بيانات في الورقة المصدر", vbExclamation
        Wb1.Close False
        Exit Sub
    End If
    
    WSdest.Cells.UnMerge
    WSdest.Cells.ClearContents
    
    OnRng.Copy
    With WSdest.Range("A1")
        .PasteSpecial xlPasteFormulas
        .PasteSpecial xlPasteFormats
    End With
    
    Application.CutCopyMode = False
    Wb1.Close False
    MsgBox "تم نسخ البيانات بنجاح", vbInformation
    
ExitHandler:
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub
    
ErrorHandler:
    MsgBox "حدث خطأ: " & Err.Description, vbCritical
    Resume ExitHandler
End Sub

 

تم تعديل بالامس في 11:31 بواسطه hegazee

[ashhma79]

جزاك الله خيرا  . اهتمامك استاذنا العبقري

جزيل الشكر  كونك دائما رمزا للعطاء اعزك الله وحفظك و يبارك في عمرك وعملك  .

[hegazee]

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

[ashhma79]

اخى الفاضل 

عند الضغط على ...

يظهر 

report

share

برجاء تحديد المطلوب

 

[Foksh]

36 دقائق مضت, ashhma79 said:

اخى الفاضل 

عند الضغط على ...

يظهر 

report

share

برجاء تحديد المطلوب

 

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

[Foksh]

22 ساعات مضت, ashhma79 said:

اخى الفاضل 

عند الضغط على ...

أخي الكريم السلام عليكم ورحمة الله وبركاته ,,

أولاً أهلا وسهلاً بك معنا في هذا الصرح الكبير .. ونتمنى أن تجد ما تبحث عنه دائماً من حلول وإجابات لإستفساراتك ..

لاختيارك الإجابة التي تريدها والتي حققت لك طلبك بشكل كامل ، انظر الفيديو التالي ، للإستفادة منه كي لا تقع في نفس المشكلة لاحقاً ..

 

 

وشكراً لك ، وأهلاً بك مرة أخرى