المساعدة في كود ترحيل

[ابو منذر عبد الله]

السلام عليكم

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

و مشكورين على المساعدة

ادخال بيانات غياب.xlsx

[ابو منذر عبد الله]

للرفع

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

[lionheart]

Sub Test()
    Dim x, y, sh As Worksheet, lr As Long, i As Long, cnt As Long
    With Sheet1
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 4 To lr
            If .Cells(i, 1).Value <> "" And .Cells(i, 7).Value <> "" Then
                If InStr(.Cells(i, 7).Value, Chr(219) & Chr(237) & Chr(209)) Then
                    Set sh = Sheet3
                ElseIf InStr(.Cells(i, 7).Value, Chr(227) & Chr(196) & Chr(222) & Chr(202)) Then
                    Set sh = Sheet4
                Else
                    Set sh = Sheet2
                End If
                x = Application.Match(.Cells(i, 1).Value, sh.Columns(1), 0)
                If Not IsError(x) Then
                    y = Application.Match(.Range("G3").Value2, sh.Rows(3), 0)
                    If Not IsError(y) Then
                        sh.Cells(x, y).Value = "*"
                        cnt = cnt + 1
                    End If
                End If
            End If
        Next i
    End With
    MsgBox "Transferred Successfully = " & cnt, 64
End Sub

 

[ابو منذر عبد الله]

لم يعمل اخي ممكن محاولة باضافة زر

 

[lionheart]

Draw any shape > Right-Click on it > Assign Macro . Select he macro name. It is not difficult at all

[هشام جودي]

السلام عليك

تفضل الملف يعمل

ادخاÙ_ بÙ_اÙ_ات غÙ_اب.xlsm

[ابو منذر عبد الله]

بارك الله فيك و ان أمكن عند الترحيل يضع القيمة في الخانة في عمود القيمة التي كتبت و ليس وضع نجمة و شكرا

ادخاÙ_ بÙ_اÙ_ات غÙ_اب (1).xlsm