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

[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

 

تم تعديل منذ 5 ساعات بواسطه hegazee

[ashhma79]

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

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

[hegazee]

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