تعديل كود الاستراد والتصدير الى الاكسيل

[بلال بلال]

السلام عليكم

لدي ورقة Horaire2027    اريد ترحيل البيانات الى ورقة Feuil1 و  Feuil12 و Feuil13

 

            1- ترحيل البيانات الى الورقة Feuil1 الحقول بالون الأزرق لا تفرغ الحقول عند الترحيل 

            2-ترحيل البيانات الى الورقة Feuil12 الحقول بالون الأصفر وعند الترحيل تفرغ الحقول

            3-ترحيل البيانات الى الورقة Feuil13 الحقول بالون الأحمر وعند الترحيل تفرغ الحقول

Horaire-18-06-2026-(04.12.06) (3).xlsb

[أبومروان]

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

 

 

اتفضل الكود بالطلب الاول لعله يكون المطلوب 👇

Sub TransferDataValues()

    Dim wsSrc As Worksheet, wsDst As Worksheet
    Dim nextRow As Long

    Set wsSrc = ThisWorkbook.Worksheets("Horaire2027")
    Set wsDst = ThisWorkbook.Worksheets("Feuil1")

    nextRow = wsDst.Cells(wsDst.Rows.Count, "A") '.End(xlUp).Row
    If nextRow < 5 Then
        nextRow = 5
    Else
        nextRow = nextRow
    End If

    wsDst.Cells(nextRow, "A").Resize(4, 9).Value = wsSrc.Range("B3:J6").Value

End Sub

 اتفضل الكود بالطلب التاني لعله يكون المطلوب 👇

Sub Transfe12()

    Dim wsSrc As Worksheet
    Dim wsDst As Worksheet
    Dim nextRow As Long

    Set wsSrc = ThisWorkbook.Worksheets("Horaire2027")
    Set wsDst = ThisWorkbook.Worksheets("Feuil12")

    nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row
    If nextRow < 5 Then
        nextRow = 5
    Else
        nextRow = nextRow + 1
    End If

    wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B9:J9").Value

End Sub

 اتفضل الكود بالطلب التالت لعله يكون المطلوب 👇

Sub Transfe13()

    Dim wsSrc As Worksheet
    Dim wsDst As Worksheet
    Dim nextRow As Long

    Set wsSrc = ThisWorkbook.Worksheets("Horaire2027")
    Set wsDst = ThisWorkbook.Worksheets("Feuil13")

    nextRow = wsDst.Cells(wsDst.Rows.Count, "A").End(xlUp).Row
    If nextRow < 5 Then
        nextRow = 5
    Else
        nextRow = nextRow + 1
    End If

    wsDst.Cells(nextRow, "A").Resize(1, 9).Value = wsSrc.Range("B13:J13").Value
    
    wsSrc.Range("B13:J13").ClearContents
End Sub

 

Copy of Horaire-18-06-2026-(04.12.06) (3).xlsb