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

[رجب جاويش]

أعلى الله من قدرك أخى الحبيب ياسر بسبب هذا التواضع الذى هو من شيم العظماء

 

تم تعديل يناير 26, 2016 بواسطه رجب جاويش

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

1 دقيقه مضت, رجب جاويش said:

أعلى الله من قدرك أخى الحبيب بسبب هذا التواضع الذى هو من شيم العظماء

 

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

أما أنتم فنبراس الإبداع والتميز على الدوام

[مختار حسين محمود]

أخى و أستاذى رجب بارك الله فيك و جزاك خيرا

أخى و أستاذى ياسر خليل بارك الله فيك و جزاك خيرا

[رجب جاويش]

أخى الفاضل الأستاذ / مختار حسين

جزاك الله كل خير على هذا المرور العطر

 

[محمد الورفلي1]

11 ساعات مضت, رجب جاويش said:

 

تفضل أخى

هذا شرح مختصر للكود

Sub ragab()
'السطور التالية لتعريف المتغيرات
Dim cl As Range, LR As Integer
Dim sh As Worksheet, R_N As Integer
'تحديد الورقة التى سوف يتعامل المتغير معها
Set sh = ورقة3
'===========================================
'السطر التالى لوقف اهتزاز الشاشة لتسريع عمل الكود
Application.ScreenUpdating = False
'تحديد قيمة خلية رقم السند
x = [G13]
'تحديد اول سطر فارغ فى العمود الخاص برقم السند فى الورقة 3
LR = sh.[G1000].End(xlUp).Row + 1
'نسخ الخلايا من ورقة الادخال
Range("A13:K13").Copy
'حلقى تكرارية لمعرفة هل رقم السند مكرر داخل الورقة 3 ام لا
For Each cl In sh.Range("G13:G" & LR)
    If cl = x Then
    'اذا وجد رقم السند مكرر يتم تحديد رقم الصف الخاص به من السطر التالى
        R_N = cl.Row
        'يتم لصق البيانات الجديدة مكان البيانات القديمة فى الورقة 3
        sh.Cells(R_N, 1).PasteSpecial xlPasteValues
        'وبعد لصق البيانات الجديدة مكان القديمة يتجة الى السطر الخاص بانهاء خاصية القص والنسخ
        GoTo 1
    End If
Next
'اذا لم يكن رقم السند مكرر فيتم نسخة فى صف جديد عن طريق السطر التالى
sh.Cells(LR, 1).PasteSpecial xlPasteValues
'السطر الخاص بانهاء خاصية القص والنسخ لازالة التحديد الموجود حول الخلايا المنسوخة
1: Application.CutCopyMode = False
' اعادة اهتزار الشاشة كما كان
Application.ScreenUpdating = True
End Sub

 

 

 

اسف على التاخير في الرد السبب انقطاع  التيار الكهربائي

 

 

10 ساعات مضت, ياسر خليل أبو البراء said:

أخي الكريم محمد

إثراءً للموضوع ..إليك الكود بشكل آخر بعيداً عن نسخ ولصق البيانات وبعيداً عن الحلقات التكرارية للبحث عن رقم السند

يمكنك إزالة رسائل التنبيه في الكود إذ أنني قمت بوضع تنبيه في حالة أ ن خلية رقم السند فارغة أو تساوي صفر

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

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

مع تحياتي لمعلمي الكبير رجب جاويش

Sub ReTransferData()
    Dim Ws As Worksheet, Sh As Worksheet
    Dim X, lRow As Integer, LR As Integer
    
    Set Ws = Sheets("ادخال"): Set Sh = Sheets("كشف")
    X = Val(Ws.Range("G13").Value)
    LR = Sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    If X <> 0 Then
        If Application.IsNA(Application.Match(X, Sh.Columns("G:G"), 0)) Then
            Sh.Range("B" & LR).Resize(1, 10).Value = Ws.Range("B13").Resize(1, 10).Value
            MsgBox "New Record", 64
        Else
            lRow = Application.Match(X, Sh.Columns("G:G"), 0)
            Sh.Range("B" & lRow).Resize(1, 10).Value = Ws.Range("B13").Resize(1, 10).Value
            MsgBox "Editing Exisitng Record At Row " & lRow, 64
        End If
    Else
        MsgBox "Receipt Number Should Not Be Empty", vbExclamation: Exit Sub
    End If
End Sub

تقبلوا تحياتي

 

 

 

استاذ ياسر  كمل جميلك ........... واعطينا وظيفة كل سطر من فظلك

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

طيب ما تتجرأ وحاول تدرس كل سطر ولو فيه سطر مش واضح نوضحه ..حاول تصطاد بنفسك يا خازمي

وإن شاء الله متابعين معاك عشان لو فيه حاجة مش واضحة

[محمد الورفلي1]

اقصي جهدي هو هذا

 

وشكراً علي التشيع

 

Sub ReTransferData()
' لتعريف المتغيرات

    Dim Ws As Worksheet, Sh As Worksheet
    Dim X, lRow As Integer, LR As Integer
    'الصفحة

    Set Ws = Sheets("ادخال"): Set Sh = Sheets("كشف")
        'رقم الخلية التي هي مرجع لرقم الايصال

    X = Val(Ws.Range("G13").Value)
           'تحديد اول سطر فارغ

    LR = Sh.Cells(Rows.Count, "B").End(xlUp).Row + 1
    
    'لم افهم المتغير   xماذا يعني
    If X <> 0 Then
    
    
        If Application.IsNA(Application.Match(X, Sh.Columns("G:G"), 0)) Then
            Sh.Range("B" & LR).Resize(1, 10).Value = Ws.Range("B13").Resize(1, 10).Value
            MsgBox "New Record", 64
        Else
            lRow = Application.Match(X, Sh.Columns("G:G"), 0)
            Sh.Range("B" & lRow).Resize(1, 10).Value = Ws.Range("B13").Resize(1, 10).Value
            MsgBox "Editing Exisitng Record At Row " & lRow, 64
        End If
    Else
        MsgBox "Receipt Number Should Not Be Empty", vbExclamation: Exit Sub
    End If
End Sub

 

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

المتغير X يشير إلى قيمة الخلية G13 التي بها رقم الإيصال فإذا كان فارغاً أو القيمة صفر ظهرت رسالة بأنه يجب ألا تكون الخلية فارغة وإذا لم لم يكن يساوي صفر ينفذ الكود

[محمد الورفلي1]

 

سوف انتظر

شرح الكود كاملاً ..... في وقت فارغك

شكراً استاذ ياسر

تم تعديل يناير 26, 2016 بواسطه محمد الخازمي

[مهند الزيدي]

للرفع

ولع المنتدى .. بحضور العمالقة محمد الخازمي .. رجب جاويش..

والمبدع ياسر خليل

[محمد الورفلي1]

1 دقيقه مضت, مهند الزيدي said:

للرفع

استاذ مهند السلام عليكم

نصيحة  اخوية اجعل موضوعك في مشاركة جديدة حتي لايتشتت القاري للموضو ع ...... ولك الخيار

[إبراهيم ابوليله]

أخى واستاذنا ياسر

الحمد لله انا بخير ولكن هى مشاغل الحياه فقط

اشكرك على السؤال

تقبل تحياتى

.....................................................................

استاذنا رجب بالفعل نحن نفتقدك

كثيرا فانت بحر علم لا يجف

نسأل الله ان يزيدك من فضله وعلمه

تقبل تحياتى

[محمد الورفلي1]

السلام عليكم

عند وضع خماية على الورقة ظهر لى خطاء في كلا الكودين ما الحل

 

 

 

 

 

ايصالي1.rar

ايصالي1.rar

تم تعديل يناير 28, 2016 بواسطه محمد الخازمي

[إبراهيم ابوليله]

اخى محمد

جرب هذا

SH.UNPROTECT

 

[رجب جاويش]

أخى الفاضل محمد

هذا الخطأ نتيجة حماية صفحة ( كشف )

ولتلافى هذا الخطأ كما أخبرك أخى ابراهيم

تضع السطر التالى فى أول الكود لفك الحماية ( بفرض كلمة المرور 1234 )

Sh.Unprotect "1234"

والسطر التالى فى اخر الكود لارجاع الحماية

Sh.Protect "1234"

 

[محمد الورفلي1]

فعلت لالكن انظر

 

 

[رجب جاويش]

عذرا أخى الفاضل

أقصد بان تضع السطر  الخاص بالحماية بعد هذا السطر

Set Sh = ورقة3

 

[محمد الورفلي1]

شكراً استاذ رجب تمام التمام