تصحيح الكود للترحيل

[marwa41]

ارجو تعديل كود الترحيل او تصحيحه و

رمضان كريم

جديد محمد مسموع.xlsm

[عبدالفتاح في بي اكسيل]

ما مشكلة الكود  يجب توضيح  اكثر  حتى يتفاعل  الاساتذه  مع  مشكلتك اختي  الكريمة 

[marwa41]

عملت كود ترحيل من فاتورة الى المبيعات لكن عند الترحيل يرحل صف واحد فقط ولا يرحل الباقى البيانات

 

[الرائد77]

تفضل أخي 

ضع  هذا مكان الكود  الذي تستعمله. تغيير بسيط على الكود الذي في الملف

Sub REDA()
 Application.ScreenUpdating = False
    
    Dim iRow As Long
    Dim rng As Range
    Dim cl As Range
    Set rng = ActiveSheet.Range("c14:c23")
    For Each cl In rng
    
    If cl <> "" Then
    
    iRow = Sheets("SLS").Range("C1048576").End(xlUp).Row + 1
    
    
        With ThisWorkbook.Sheets("SLS")
        
           .Range("B" & iRow).Value = iRow - 1
           .Range("C" & iRow).Value = Sheets("INV").Range("D7").Value
           .Range("D" & iRow).Value = Sheets("INV").Range("D8").Value
           .Range("E" & iRow).Value = cl.Value
           .Range("F" & iRow).Value = cl.Offset(, 1).Value
           .Range("G" & iRow).Value = cl.Offset(, 2).Value
           .Range("H" & iRow).Value = cl.Offset(, 3).Value
           .Range("I" & iRow).Value = cl.Offset(, 4).Value
           .Range("J" & iRow).Value = Sheets("INV").Range("G24").Value
           .Range("K" & iRow).Value = Sheets("INV").Range("G25").Value
           .Range("L" & iRow).Value = Sheets("INV").Range("G26").Value
           .Range("M" & iRow).Value = Sheets("INV").Range("G27").Value
                    
        End With
           End If
                Next

    
    Sheets("INV").Range("D8").Value = ""
    Sheets("INV").Range("C14").Value = ""
    Sheets("INV").Range("C15").Value = ""
    Sheets("INV").Range("C16").Value = ""
    Sheets("INV").Range("C17").Value = ""
    Sheets("INV").Range("C18").Value = ""
    Sheets("INV").Range("C19").Value = ""
    Sheets("INV").Range("C20").Value = ""
    Sheets("INV").Range("C21").Value = ""
    Sheets("INV").Range("C22").Value = ""
    Sheets("INV").Range("C23").Value = ""
     
    Sheets("INV").Range("E14").Value = ""
    Sheets("INV").Range("E15").Value = ""
    Sheets("INV").Range("E16").Value = ""
    Sheets("INV").Range("E17").Value = ""
    Sheets("INV").Range("E18").Value = ""
    Sheets("INV").Range("E19").Value = ""
    Sheets("INV").Range("E20").Value = ""
    Sheets("INV").Range("E21").Value = ""
    Sheets("INV").Range("E22").Value = ""
    Sheets("INV").Range("E23").Value = ""
    
     
    Sheets("INV").Range("F14").Value = ""
    Sheets("INV").Range("F15").Value = ""
    Sheets("INV").Range("F16").Value = ""
    Sheets("INV").Range("F17").Value = ""
    Sheets("INV").Range("F18").Value = ""
    Sheets("INV").Range("F19").Value = ""
    Sheets("INV").Range("F20").Value = ""
    Sheets("INV").Range("F21").Value = ""
    Sheets("INV").Range("F22").Value = ""
    Sheets("INV").Range("F23").Value = ""
    Sheets("INV").Range("G25").Value = ""
    Sheets("INV").Range("G26").Value = ""
    
    
    Application.ScreenUpdating = True
End Sub

 

[سليم حاصبيا]

بعد اذن اخي الرائد

لا ضرورة لكل هذه الحلفات التكرارية (بدل التنقل داخل النطاق المطلوب نقله  خلية  خلية ) انسخ النطاق كاملاُ الى الخلية الهدف

لاحظ هذا الكود

Option Explicit

Sub My_code_1()
  
    Dim CRow%, jRow%, HowMany%
    Dim rng As Range
    Dim I As Worksheet, S As Worksheet
      
    Set I = Sheets("INV"): Set S = Sheets("SLS")
    Set rng = Sheets("INV").Range("c14:c23")
    
    HowMany = Application.CountA(I.Range("c14").Resize(10))
    CRow = S.Range("C1048576").End(xlUp).Row + 1
    jRow = S.Range("J1048576").End(xlUp).Row + 1
    CRow = Application.Max(jRow, CRow)
    
    I.Cells(14, "C").Resize(HowMany, 5).Copy
    S.Cells(CRow, "c").PasteSpecial (12)
    
    I.Range("G24:G27").Copy
      With S.Cells(CRow + HowMany, "J")
        .PasteSpecial (12), Transpose:=True
        .Resize(, 4).Interior.ColorIndex = 6
      End With
    
    S.Cells(CRow, "H") = I.Cells(8, "D")
    S.Cells(CRow, "I") = I.Cells(7, "D")
 I.Range("C14:C23").ClearContents
 I.Range("D8").ClearContents
 Application.CutCopyMode = False
End Sub
 

الملف مرفق

Salim_Book.xlsm

[marwa41]

ما شاءا الله 

يجعله الله فى ميزان حسناتكم

[أحمد يوسف]

    marwa41

أين الضغط على الإعجاب لهذه الإجابة الممتازة واعتقد ان هذا اقل ما يقدم لصاحب الفضل بعد ربنا فى حل مشكلتك ؟!!!💙