نسخ ورقة الى مستند أخر

[ashhma79]

السادة الأفاضل

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

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

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

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

و لكن تظهر انه يوجد مشكلة فى الكود التالى

 

book2.Sheets("إدخال بيانات أساسية").UsedRange.Copy book1.Sheets("إدخال بيانات أساسية").Range("a1")

 

نسخ.rar

[محمد هشام.]

 

وعليكم السلام ورحمة الله تعالى وبركاته  

لاحظت أن الكود الخاص بك يسبب خطأ أثناء التنفيذ لأنه يحاول نسخ كامل النطاق المستخدم UsedRange من ملف book2 إلىbook1 

بشكل مباشر وهذا يشمل الأزرار والأشكال وأي عناصر رسومية أخرى في الورقة مما يؤدي إلى توقف الكود أو ظهور أخطاء وبطء في الأداء بسبب كثرة العناصر المنسوخة

لذلك أنصحك باستخدام الكود التالي الذي يعتمد على نسخ الصيغ والتنسيقات فقط عبر PasteSpecial مما يمنع نسخ العناصر غير المرغوب فيها ويضمن عمل الكود بسلاسة وبدون مشاكل

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 = "إدخال بيانات أساسية"

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "اختر ملف Excel كمصدر للبيانات"
        .Filters.Clear: .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb"
        If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملف", vbExclamation: Exit Sub
        FilePath = .SelectedItems(1)
    End With

    Set Wb1 = Workbooks.Open(FilePath)
    Set Wb2 = ThisWorkbook

    On Error Resume Next
    Set WSdata = Wb1.Sheets(WSname)
    Set WSdest = Wb2.Sheets(WSname)
    On Error GoTo 0

    If WSdata Is Nothing Or WSdest Is Nothing Then
        MsgBox "لم يتم العثور على ورقة العمل", vbCritical
        Wb1.Close False
        Exit Sub
    End If

    Set OnRng = WSdata.UsedRange
    WSdest.Cells.UnMerge
    WSdest.Cells.ClearContents

    OnRng.Copy
    With WSdest.Range("A1")
        .PasteSpecial xlPasteFormulas
        .PasteSpecial xlPasteFormats
    End With

    Application.CutCopyMode = False
    Application.Goto WSdest.Range("A1"), True
    Wb1.Close False

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

    MsgBox "تم نسخ البيانات بنجاح", vbInformation
End Sub

 

نسخ.rar

[ashhma79]

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

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