منع الترحيل في حالة المكرر

[kh_yh]

مسا الخير جميعا وتحية طيبة 
كل عام وانتم بخير
الملف المرفق يحتوي كود ترحيل واستعلام لاستخراج كشف حساب 
محتاج اذا كان رقم المستند مكرر ان يقوم باظهار مسج يبين لي ان رقم فاتورة المبيعات للعميل خالد مكررة 
او رقم سند القبض للعميل احمد مكرر
كما لاحظة ان الترحيل يصبح بطيئ في حال زيادة البيانات وذلك لوجود كود في شيت 2 يقوم بتعديل الرصيد اذا تم التعديل عليه فهل يوجد لهذه المشكلة حل

(13-05-2018) كشف حساب.xlsm

[kh_yh]

up....

[احمدزمان]

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

و انته بصحة و سلامة

اعتقد و اظن 

انك لست محتاج الى كوود 

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

حسب ما فهمت 

او المطلوب غير ذلك

[kh_yh]

اخي اذا قمت بتحميل الملف فه يحتوي على اكود ولا اظن الن تحقق من الصحة يعمل 
حيث انني احتاج عندما يجد قيمة مكرر من الموجود في صفحة رقم 1 من الصفحة رقم 2 يوقف الترحيل ويقوم باخباري ان المدخل مثلا فاتورة رقم 3 مكررة

تم تعديل مايو 24, 2018 بواسطه kh_yh

[kh_yh]

up......

[احمدزمان]

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

جرب المرفق

تم استخدام التحقق من صحة

ادخل اي رقم سند

اذا كان موجود من السابق في ورقة 2 تظهر لك رسالة

 

كشفحساب.xlsm

[kh_yh]

صديقي احمد انا اشكرك على الحل 
ولكن انا ارغب ان يكون الحل على شكل كود

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

Sub TRans()
lr2 = Sheet1.Cells(Rows.Count, "b").End(xlUp).Row
If Cells(lr2, 4) = "" Or Cells(lr2, 5) = "" Or Cells(lr2, 6) = "" Or Cells(lr2, 6) = "" Then
MsgBox "ضع صفر مكان القيم الفارغة وضع الملاحظة"
Else
Dim myArray() As Variant
myArray = Range("a2:h" & Cells(Rows.Count, 1).End(xlUp).Row)
With Sheet2
lr = .Cells(.Rows.Count, "b").End(xlUp).Row
For Each c In Sheet1.Range("d2:d" & lr2)
For Each cc In Sheet2.Range("d2:d" & lr)
If c = cc Then MsgBox "Please Check Invoices number....": Exit Sub
Next
Next
.Cells(Rows.Count, 1).End(xlUp)(2, 1).Resize(UBound(myArray, 1), UBound(myArray, 2)).Value = myArray
For x = 2 To lr
Data = Application.WorksheetFunction.SumIf(.Range("$b$2:b" & x), .Range("b" & x), .Range("$e$2:e" & x))
Data2 = Application.WorksheetFunction.SumIf(.Range("$b$2:b" & x), .Range("b" & x), .Range("$f$2:f" & x))
.Range("g" & x).Value = Data - Data2
Next x
End With
MsgBox "DONE....", 64
End If
End Sub

حيث ان النص الملون بالاصفر مسؤول عن التحقق ولكن هذا الحل يبحث بالرقم فقط ولكن مثالي يجب عند التحقق يربط نوع السند مع رقم السند حيث ان اذا تكرر رقم 1 لرقم الفاتورة ورقم السند فهذا لا يعتبر تكرار حيث يجل ان لا يتكرر نوع سند يحمل نفس رقم السند مثلا لا يجب ان يكون هناك فاتورتين تحمل نفس الرقم اما وجود سند قبض وفاتورة تحمل نفس الرقم فلا مشكلة لا يعتبر تكرار

[kh_yh]

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

(13-05-2018) كشف حساب.xlsm

[احمدزمان]

اذا المطلوب النقل الى شيت 2 من شيت 1

بدون التدخل الى شيت3

صح

 

[kh_yh]

صحيح

لا بدون تدخل حيث ان الشيت رقم 3 هي عبارة عن كشف حساب مستمد من البياتات في الشيت رقم 2

بمعنى ان الشيت رقم 3 هدفها الاستعلام فقط

[احمدزمان]

59 دقائق مضت, kh_yh said:

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

(13-05-2018) كشف حساب.xlsm

تمام 

الفكرة وصلت

وهناك عدة طرق للحل

و انا سوف اختار اسهلها

سوف نعمل كوود

يثوم بمراجعة البيانات و مقارنتها مع البيانات في شيت2

ثم

يكتب لك مكرر امام البيانات المكررة قبل الترحيل

مع رقم الصف للبانات المكررة

[kh_yh]

لماذا لا تكون عن طريق مسج بوكس 
مثلا الفاتورة رقم 3 مكررة

او سند قبض 4 مكرر

[احمدزمان]

ممكن

لا مشكلة

ان شاء الله

[kh_yh]

شكرا الك 

بارك الله فيك 

انا بانتظار حلك 

[احمدزمان]

عملنا كوود جديد يقوم بكل الخطوات

كما يلي

ياخذ نوع السند و رقم السند

اذا كان لايوجد رقم للسند او لا يوجد نوع للسند يعني فراغ - يعطيك رسالة اكمال البيانات

يذهب الى ورقة 2 يشيك على كل البيانات في ورقة 2 من الصف 2 الى نهاية الورقة

اذا وجد اي تطابق مع رقم السند و نوع السند الإثنان معا - يعطيك رسالة انه مكرر

----

اذا لم يجد السند مكرر يقوم بترحيل كامل الصف للبيانات ويمسح لك بيانات الصف الذي تم ترحيله

بعد انتهاء عمل الكود سوف يبقى لديك في ورقة 1 البيانات المكررة و البيانات الناقصة

اما البيانات التي اكتملت و غير مكررة سوف تجدها قد نقلت الى ورقة 2 و غير موجودة في ورقة 1

Sub MUKArar()
Dim FS As Worksheet, TS As Worksheet
Dim FR, TR, ER1, ER2, Q1, Q2
Set FS = Sheets("Sheet1")
Set TS = Sheets("Sheet2")
ER1 = FS.UsedRange.Rows.Count
ER2 = TS.UsedRange.Rows.Count
TR2 = Application.CountA(TS.Range("A1:A5555"))
FS.Range("I2:I" & ER1).ClearContents

For FR = 2 To ER1
Q1 = FS.Cells(FR, 3).Text
Q2 = FS.Cells(FR, 4).Value
    If Q1 = "" Or Q2 = "" Then
    FS.Cells(FR, 9) = "اكمل ادخال البيانات"
    MsgBox FS.Cells(FR, 9).Text
    GoTo 7
    End If
    For TR = 2 To ER2
        If TS.Cells(TR, 3) = Q1 And TS.Cells(TR, 4) = Q2 Then
        FS.Cells(FR, 9) = "مكرر - " & TR
        MsgBox Q1 & " - " & Q2, , "مكرر"
        GoTo 7
        End If
    Next TR
6 TR2 = TR2 + 1
If TS.Cells(TR2, 1) <> "" Then GoTo 6
    If FS.Cells(FR, 9) = "" Then
        For FC = 1 To 9
        TS.Cells(TR2, FC) = FS.Cells(FR, FC)
        FS.Cells(FR, FC).ClearContents
        Next FC
    End If

7
Next FR

End Sub

جرب المرفق

 

اذا كانت البيانات كثيرة 

سوف يستغرق و قت اطول

لأنه يقوم بتشييك صف صف

 

كشفحساب.xls

[kh_yh]

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

[احمدزمان]

نعم

قم بلصق الكود محل الكود السابق و يعمل ان شاء الله

=======

المصفوفات لن تغير من الأمر شيئ

على الوضع للكود الحالي حسب طلبك

[kh_yh]

صديقي يظهر لي مشاكل بالملف ولا استطيه اغلاقه الا عن طريق كنترول والت ودليت 

 

رسالة المشكلة 
excel cannot completed this task with available resoures . choose less data or close other application
وتظهر هذه الرسالة عند تفريغ شيت 2 كما انني لا اريد ظهور اي شئ يظهر بالعامود i 
و في الشيت رقم 1 يعتمد على اخر صف بع بيانات بمعنى لو كان احد الصفوف الاربعة المحدد عندي في شيت 1 فارغ لا يظهر طلب باكمال البيانات 

[احمدزمان]

السلام عليكم

انا جربت الملف عندي شغال تمام

عمود آي نعمله بسيطة

[kh_yh]

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

 

[احمدزمان]

المشكلة في هذا الكود الموجود في شيت 2

Private Sub Worksheet_Change(ByVal Target As Range)

lr = Range("A2").End(xlDown).Row
If Target.Column = 2 Or Target.Column = 5 Or Target.Column = 6 Then
   Range("g2:g" & lr).FormulaR1C1 = "=SUMIF(R2C2:RC[-5],RC[-5],R2C5:RC[-2])+SUMIF(R2C2:RC[-5],RC[-5],R2C6:RC[-1])"
    Range("g2:g" & lr).Value = Range("g2:g" & lr).Value
End If
End Sub

حيث انه عند افراغ ورقة 2 من البيانات فانة يقوم بوضع الدالة Sumif لكامل خلايا الورقة 2 في العمود G

 

ولكن

ان شاء الله نجد الحل في المساء

[kh_yh]

ان شاء الله 
صديقي الاستاذ احمد هذا الكود ضروري حيث اذا تم اي تعديل بعد الترحيل يقوم بتعديل الرصيد 

[احمدزمان]

جرب الآن

 

كشفحساب.xls

[kh_yh]

اخي احد مبدئيا الحل جيد 

ولكن يوجد مشكلة في ترصيد الذمة الاخيرة حيث تظهر بدون رصيد  

تم تعديل مايو 26, 2018 بواسطه kh_yh

[kh_yh]

صديقي انا اكتشفت سبب المشكلة وهو انه يقوم بنقل الخلية الفارغة من شيت واحد حيث انه بعد وضع قيمة الرصيد يقوم بنقل الخلية الفارغة فيختفي هذا الرصيد 
هل لها حل ؟؟؟

تم تعديل مايو 26, 2018 بواسطه kh_yh