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

[ashhma79]

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

مطلوب ضبط معادلة نسخ درجات فقط من

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

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

و ان يبدا اللصق بداية من خلية f9   حتى خلية 609 s

نسخ درجات فقط.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 = "ملف 1"

    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

    ' تحديد النطاق من F9 إلى S609
    Set OnRng = WSdata.Range("F9:S609")
    WSdest.Cells.UnMerge
    WSdest.Range("F9:S609").ClearContents ' مسح النطاق المحدد فقط

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

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

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

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

 

[ashhma79]

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

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

[hegazee]

آمين يا رب العالمين. و إياكم أجمعين