الترحيل بمعلوميه خليه

[waleedsh3alan]

ارجو من الاساتذه الكبار كود ترحيل من ملف الاذون الى الصرف والاضافه بمعلوميه خليه c2

مخزن.xlsx

[ياسر خليل أبو البراء]

السلام عليكم نبدأ بها 

جرب الكود التالي

Sub Test()
    Dim ws As Worksheet, sh As Worksheet, sTarget As String, lr As Long, m As Long, iRow As Long
    Application.ScreenUpdating = False
    Set ws = ThisWorkbook.Worksheets("اذن")
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    If lr < 6 Then MsgBox "No Data", vbExclamation: Exit Sub
    Select Case ws.Range("C2").Value
        Case "اذن صرف": sTarget = "صرف"
        Case "اذن اضافه": sTarget = "اضافه"
        Case Else: MsgBox "No Such Worksheet", vbExclamation: Exit Sub
    End Select
    Set sh = ThisWorkbook.Worksheets(sTarget)
    m = sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
    For iRow = 6 To lr
        sh.Range("A" & m).Resize(, 6).Value = Array(sh.Range("A" & m).Row - 2, ws.Range("E2").Value, ws.Range("C4").Value, ws.Range("C3").Value, ws.Cells(iRow, 1).Value, ws.Cells(iRow, 2).Value)
        sh.Range("I" & m).Value = ws.Cells(iRow, 4).Value
        If sh.Name = "اضافه" Then
            sh.Range("J" & m).Value = ws.Cells(iRow, 5).Value
        End If
        m = m + 1
    Next iRow
    Application.ScreenUpdating = True
    MsgBox "Done", 64
End Sub

 

[waleedsh3alan]

ياسر خليل أبو البراء

لك جزيل الشكر على ماقمتم به وذادكم الله من فضله