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

[sam_farh]

السلام عليكم اصدقائي المحترمين

اولا اشكر كل القائمين علي الصفحه جزاهم الله خيرا

ثانيا المفروض ان كود الترحيل لو رقم الوثيقه مكرر لا يتم الترحيل ولكن يعطيني رساله مكرر حتي ولو لم يكن مكرر في صفحه الترحيل

ثالثا اريد اضافه انه لا يتم الترحيل الا ان كانت خانه الصنف بها اي صنف في صفحه المبيعات

شكرا

 

عرض تجربه1.xlsb

تم تعديل أكتوبر 23, 2023 بواسطه sam_farh
خطاء

[sam_farh]

السلام عليكم هل في مشكله في عرضي للمشكله ام في الملف 

[محمد هشام.]

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

اول مشكلة هي انك رافع الملف بدون الغاء باسوورد محرر الاكواد مع عدم ادراجه داخل المشاركة  بحيث نظطر لكسره لمعرفة مكان الخطأ  

تفضل اخي استبدل كود الترحيل بالكود التالي 

Sub HARD()
Dim WS1     As Worksheet
Dim WS2     As Worksheet
Dim Rng      As Range
Dim A, B, C, D As String

Set WS1 = ThisWorkbook.Sheets("المبيعات")
Set WS2 = ThisWorkbook.Sheets("ترحيل")
  Set Rng = WS1.Range("B8:E24")
A = WS1.[E2]: B = WS1.[E3]: C = WS1.[B1]: D = WS1.Range("B2")
If Application.WorksheetFunction.CountIf(WS2.Range("B:B"), WS1.[E2].Value) > 0 Then MsgBox "رقم الوثيقة موجود مسبقا", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub
If Application.WorksheetFunction.CountA(WS1.Range("E8:E24")) = 0 Then Exit Sub
 Application.ScreenUpdating = False
    F = Rng
    For i = 1 To UBound(F)
       If Len(F(i, 4)) > 0 Then
WS2.Range("b" & Rows.Count).End(xlUp).Offset(1).Resize(1, 4).Value _
= Array(A, B, C, D)
On Error Resume Next '
    Rng.SpecialCells(xlCellTypeConstants).ClearContents
    WS1.Range("B1,B2").Value = Empty
On Error GoTo 0
With WS2.Range("A2:A" & WS2.Cells(Rows.Count, "B").End(xlUp).Row)
        .Value = Evaluate("ROW(" & .Address & ")-1")
         End With


        End If
    Next
Application.ScreenUpdating = True
   
MsgBox "تم ترحيل البيانات بنجاح", vbInformation, "تعليمات "
  

End Sub

 

 

 

 

عرض تجربه1.xlsm

تم تعديل أكتوبر 24, 2023 بواسطه محمد هشام.

[sam_farh]

22 ساعات مضت, sam_farh said:

 

 

 

21 ساعات مضت, Akram Galal said:

السلام عليكم

اريد ان تظهر نص الرسالة في منتصف الفورم

مرفق صورة بالرسالة التي تظهر عندي واريد تعديلها

تم تعديل أكتوبر 25, 2023 بواسطه sam_farh

[sam_farh]

12 ساعات مضت, محمد هشام. said:

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

اول مشكلة هي انك رافع الملف بدون الغاء باسوورد محرر الاكواد مع عدم ادراجه داخل المشاركة  بحيث نظطر لكسره لمعرفة مكان الخطأ  

تفضل اخي استبدل كود الترحيل بالكود التالي 

Sub HARD()
Dim WS1     As Worksheet
Dim WS2     As Worksheet
Dim Rng      As Range
Dim A, B, C, D As String

Set WS1 = ThisWorkbook.Sheets("المبيعات")
Set WS2 = ThisWorkbook.Sheets("ترحيل")
  Set Rng = WS1.Range("B8:E24")
A = WS1.[E2]: B = WS1.[E3]: C = WS1.[B1]: D = WS1.Range("B2")
If Application.WorksheetFunction.CountIf(WS2.Range("B:B"), WS1.[E2].Value) > 0 Then MsgBox "رقم الوثيقة موجود مسبقا", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub
If Application.WorksheetFunction.CountA(WS1.Range("E8:E24")) = 0 Then Exit Sub
 Application.ScreenUpdating = False
    F = Rng
    For i = 1 To UBound(F)
       If Len(F(i, 4)) > 0 Then
WS2.Range("b" & Rows.Count).End(xlUp).Offset(1).Resize(1, 4).Value _
= Array(A, B, C, D)
On Error Resume Next '
    Rng.SpecialCells(xlCellTypeConstants).ClearContents
    WS1.Range("B1,B2").Value = Empty
On Error GoTo 0
With WS2.Range("A2:A" & WS2.Cells(Rows.Count, "B").End(xlUp).Row)
        .Value = Evaluate("ROW(" & .Address & ")-1")
         End With


        End If
    Next
Application.ScreenUpdating = True
   
MsgBox "تم ترحيل البيانات بنجاح", vbInformation, "تعليمات "
  

End Sub

 

 

 

 

عرض تجربه1.xlsm 277.52 kB · 5 downloads

بعتزر بجد مخدتش بالي ياريت كان حد نبهني

وعلي العموم الف شكر وجزاك الله خيرا فعلا كود ناجح جدا

وهناك اضافه بسيطه جدا عشان الاصدقاء يستفيدو

Sub HARD()
Dim WS1     As Worksheet
Dim WS2     As Worksheet
Dim Rng      As Range
Dim A, B, C, D As String

Set WS1 = ThisWorkbook.Sheets("المبيعات")
Set WS2 = ThisWorkbook.Sheets("ترحيل")
  Set Rng = WS1.Range("B8:E24")
A = WS1.[E2]: B = WS1.[E3]: C = WS1.[B1]: D = WS1.Range("B2")
If Application.WorksheetFunction.CountIf(WS2.Range("B:B"), WS1.[E2].Value) > 0 Then MsgBox "رقم الوثيقة موجود مسبقا", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub
If Application.WorksheetFunction.CountA(WS1.Range("E8:E24")) = 0 Then MsgBox "اكمل البيانات حتي يتم الترحيل", vbOKOnly + vbCritical + vbDefaultButton1 + vbApplicationModal, "انتباه": Exit Sub
 Application.ScreenUpdating = False
    F = Rng
    For i = 1 To UBound(F)
       If Len(F(i, 4)) > 0 Then
WS2.Range("b" & Rows.Count).End(xlUp).Offset(1).Resize(1, 4).Value _
= Array(A, B, C, D)
On Error Resume Next '
    Rng.SpecialCells(xlCellTypeConstants).ClearContents
    WS1.Range("B1,B2").Value = Empty
On Error GoTo 0
With WS2.Range("A2:A" & WS2.Cells(Rows.Count, "B").End(xlUp).Row)
        .Value = Evaluate("ROW(" & .Address & ")-1")
         End With

        End If
    Next
Application.ScreenUpdating = True
   
MsgBox "تم ترحيل البيانات بنجاح", vbInformation, "تعليمات"
  

End Sub

 

تم تعديل أكتوبر 25, 2023 بواسطه sam_farh