طلب برنامج حركة المراسلات اليومية الصادرة والواردة

[عادل الشربيني]

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

لو تكرمتم اريد برنامج لتنظيم حركة المراسلات اليوميه الصادره والوارده

[Ali Mohamed Ali]

اهلا بك اخ كريم فى المنتدى

جرب هذا

اسم المستخدم : Mrhb

كلمة السر : 1111

 

الصادر والوارد.mdb

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

اثراءً للموضوع     و بعد اذن اخي علي

هذا الملف

الكود

Option Explicit

Sub TransferData()
Dim My_Sh As Worksheet, My_Rg As Range

Dim My_row%, Rp%, i%, My_Match%
Dim Ar1(1 To 2), Ar2(1 To 2)
Ar1(1) = "Sader": Ar1(2) = "Wared"
Ar2(1) = "صادر": Ar2(2) = "وارد"
Dim Sh_Name$

Rp = Principal.Cells(Rows.Count, 2).End(3).Row
 If Rp <= 3 Then MsgBox "لا يوجد بيانات لنقلها", 1048640: GoTo Exit_Me

Sh_Name = Application.Index(Ar1, Application.Match(Principal.Range("a2"), Ar2, 0))
  Set My_Sh = Sheets(Sh_Name)
  My_row = My_Sh.Cells(Rows.Count, 1).End(3).Row + 1
  
 Set My_Rg = Principal.Range("b4:E" & Rp)
    For i = 1 To My_Rg.Rows.Count
        If Application.CountA(My_Rg.Cells(i, 1).Resize(1, 4)) < 4 Then
          MsgBox "هناك بيانات غير مكتملة في النطاق" & Chr(10) & _
            My_Rg.Cells(i, 1).Resize(1, 4).Address & Chr(10) _
            & "لا يمكن الترحيل", 1048640
          GoTo Exit_Me
        End If
    Next
    '==========================================
     For i = 1 To My_Rg.Rows.Count
        On Error Resume Next
        My_Match = Application.Match(My_Rg.Cells(i, 1), My_Sh.Range("a:a"), 0)
        If My_Match Then MsgBox "There Are Duplicates" & Chr(10) & My_Rg.Cells(i, 1) & _
        " is Already existe in Sheet: " & My_Sh.Name: GoTo Exit_Me:
        On Error GoTo 0
    Next
    
    '=======================================
     
  For i = 1 To My_Rg.Rows.Count
    My_Sh.Range("a" & My_row).Resize(My_Rg.Rows.Count, 4).Value = My_Rg.Value
    My_row = My_Sh.Cells(Rows.Count, 1).End(3).Row
    Principal.Range("b2") = My_Sh.Range("a" & My_row)
    
  Next
     My_Rg.ClearContents
Exit_Me:
Erase Ar1: Erase Ar2: Set My_Rg = Nothing: Set My_Sh = Nothing
       On Error GoTo 0
End Sub

الملف

 

Sader_Wared.xlsm