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

[بلال بلال]

السلام عليكم

لدي ورقة 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

[بلال بلال]

استاذ يارك لله فيك

استاذ الحقول بالون الابيض هل تسطيع تعديل بترحيل مرة واحدة 

استاذ ورقة Feuil1 قد قمت بتعديل عليها 

الحقول يكون في صف واحد

استاذ الحقول بالون الاصفر يتم افراغ الحقول

استاذ عند تكون الحقول فارغ لا يتم الترحيل

بارك الله فيك

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

[أبومروان]

 

اتفضل الاكواد بعد التعديل 

لعله يكون المطلوب واخبرنا بالنتجه

اليك بعض الاكواد ممكن تساعدك 

 

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

اخر كود الترحيل وغير النطاق زاي ما هو موضع 

wsSrc.Range("B13:J13").ClearContents

لو مش عايز ترحل لو الخلايا فارغه

قبل كود الترحيل وغير النطاق زاي ما هو موضح

If WorksheetFunction.CountA(wsSrc.Range("B4:J4")) = 0 Then
    MsgBox "الخلايا  فارغة لم يتم الترحيل.", vbExclamation
    Exit Sub
End If

Sub Transfer1()

    Dim wsSrc As Worksheet, wsDst As Worksheet

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

    If WorksheetFunction.CountA(wsSrc.Range("B4:J4")) = 0 Then
        MsgBox "النطاق  فارغ لم يتم الترحيل.", vbExclamation
        Exit Sub
    End If

    If WorksheetFunction.CountA(wsSrc.Range("B6:I6")) = 0 Then
        MsgBox "النطاق فارغ لم يتم الترحيل.", vbExclamation
        Exit Sub
    End If

    wsDst.Range("A6:I6").Value = wsSrc.Range("B4:J4").Value
    wsDst.Range("J6:Q6").Value = wsSrc.Range("B6:I6").Value

End Sub

Sub Transfe12()

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

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

    If WorksheetFunction.CountA(wsSrc.Range("B9:J9")) = 0 Then
        MsgBox "النطاق  فارغ لم يتم الترحيل.", vbExclamation
        Exit Sub
    End If

    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, wsDst As Worksheet
    Dim nextRow As Long

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

    If WorksheetFunction.CountA(wsSrc.Range("B13:J13")) = 0 Then
        MsgBox "النطاق  فارغ لم يتم الترحيل.", vbExclamation
        Exit Sub
    End If

    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 Copy of Horaire-18-06-2026-(04.12.06) (3).xlsb