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

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

السلام عليكم

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

 

 

ترحيل.rar

[رجب جاويش]

أخى محمد

جرب الكود التالى

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]
LR = sh.[G1000].End(xlUp).Row + 1
Range("A13:K13").Copy
For Each cl In sh.Range("G13:G" & LR)
    If cl = x Then
        R_N = cl.Row
        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

 

ترحيل.rar

ترحيل.rar

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

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

السلام عليكم

بارك الله فيك ... جعله الله لك ذخر في الدنيا والاخرة 

[رجب جاويش]

أخى محمد

تم اضافة تعديل بسيط جدا للكود لا يؤثر فى عملية الترحيل

 

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

التعديل الثاني اظهر لي مشكلة  "" الاول ادي الغرض بمتياز .. شكراً استاذ رجب

[رجب جاويش]

أخى محمد

يرجى توضيح الخطأ الذى يحدث حتى تتم الاستفادة وتلافى هذا الخطأ

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

السلام عليكم

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

اريد طلبين لو تكرمت

1/ ما الفرق بين         

GoTo 1

       و

          اعتقد هنا تقول للكود ايقاف هل هذا صحيح ام لا    Exit Sub

 

والطلب الثاني وظيفة كل سطرحتي استخدمة حسب رغبي اكون .
   

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]
LR = sh.[G1000].End(xlUp).Row + 1
Range("A13:K13").Copy
For Each cl In sh.Range("G13:G" & LR)
    If cl = x Then
        R_N = cl.Row
        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

 

 

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

[رجب جاويش]

جزاك الله خيرا اخى محمد

 

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

استاذ  رجب

ماوظيفة هذا السطر
 

1: Application.CutCopyMode = False

 

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

[رجب جاويش]

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

هذا السطر لانهاء خاصية النسخ او القص

حتى يتم ازالة الخطوط المنقطة حول الخلايا التى تم نسخها

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

كلام كبير ..............

[رجب جاويش]

تفضل أخى

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

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

 

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

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

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

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

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

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

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

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

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

 

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

اخى واستاذنا رجب

والله ليك وحشه كبيره قوووووووووووووووووووى

منور المنتدى طبعا

اعمالك دائما ما نقف امامها لفهمها

ودائما ما يسهل التعامل معها

نسأل الله الا يحرمنا منك

تقبل تحياتى

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

اخى ياسر

ايه الجمال والحلاوه

دى

كود جميل وبسيط

ولكن هل يمكن تعديل الكود

ليقوم بترحيل نطاق من البيانات

بحيث يكون النطاق ديناميكى

تقبل تحياتى

[رجب جاويش]

أخى الحبيب / ابراهيم

جزاك الله كل خير على هذه الكلمات الطيبة والشعور الطيب

والله المنتدى كله واحشنى جدا

وربنا يديم المعروف والمودة

 

 

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

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

شكرا لك أخي العزيز ياسر خليل..

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

 

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

أخي العزيز " ياسر " هل ممكن تعديل على الكود الترحيل التالي الذي هو أحد أبداعاتك .. لكي نتخلص من القص واللصق والتكرار... وكذلك من مسألة Clear content مابعد الترحيل لكي لا يقوم بتكرار ترحيل نفس الحقل أو عند تغيير الحقل

Sub TarhilData()
    Dim WS As Worksheet, SH As Worksheet
    Dim X As Long, Y As Long, Cell As Range
    Dim lRow As Long
    Set WS = Sheets("ÇáÈíÇäÇÊ"): Set SH = Sheets("ÃÌæÑ ÇáØÈíÈ")
    Application.ScreenUpdating = False
        For Each Cell In WS.Range("P2:p11")
            If Not IsEmpty(Cell) Then
                X = Application.WorksheetFunction.Match(Cell.Value, SH.Rows(1), 0)
                lRow = SH.Cells(49, X).End(xlUp).Row + 1
                
                WS.Range(Cell.Offset(, -14), Cell.Offset(, -12)).Copy
                SH.Cells(lRow, X).PasteSpecial xlPasteValues
                Cell.Offset(, 12).Copy
                SH.Cells(lRow, X + 8).PasteSpecial xlPasteValues
                
                On Error Resume Next
                    Y = Application.WorksheetFunction.Match(Cell.Offset(, -15), Range(SH.Cells(2, X), SH.Cells(2, X + 8)), 0)
                    SH.Cells(lRow, X + Y - 1).Value = Cell.Offset(, -1).Value
                On Error GoTo 0
            End If
        Next Cell
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
End

 

جدول إجور.rar

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

[رجب جاويش]

شكرا لك أخى الفاضل مهند

وجزاك الله خيرا

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

أخي الغالي إبراهيم

حمداً لله على سلامتك ..فينك بعد الإشراف اختفيت فجأة

بالنسبة للتعامل مع الأكواد من السهل تحويل النطاق ليكون ديناميكي بكل سهولة عن طريق تحديد بداية النطاق ونهايته عن طريق معرفة آخر سطر به بيانات ..

الأخ الفاضل مهند

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

الأخ الحبيب والمعلم الكبير رجب .. أحب أن أرى نقدك بالنسبة للكود ، لا يهم إذا كانت هناك نقاط ضعف في الكود فعن طريق مناقشة الكود يمكن الوصول لأفضل الحلول معاً ..معاً نرتقي

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

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

شكرا لك اخي العزيز ياسر ..

الموضوع مطروح مسبقا على الرابط

 

 

[رجب جاويش]

أخى ياسر

بجد والله أنا اقف مبهورا أمام ابداعاتك لأتعلم منها

وفعلا فكرة جميلة فكرة النقاش لتبادل الخبرات

وبالنسبة للكود ما رأيك فى هذا الاختصار

Sub ragab()
Set Sh = ورقة3
x = [g13]
T = Application.Match(x, Sh.Columns("G:G"), 0)
If Not IsNumeric(T) Then T = Sh.[G1000].End(xlUp).Row + 1
Sh.Range("B" & T).Resize(1, 10).Value = Range("B13").Resize(1, 10).Value
End Sub

 

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

أخي الحبيب رجب

جزيت خيراً على كلماتك الرقيقة وما أنا إلا قطرة في بحر علمكم الكبير أيا معلمي ...

بارك الله فيك على الاختصار الرائع

بالطبع يمكن اختصار الكود كما قدمته لنا في شكل أجمل .. ولكن لي رجاء ألا تنسى الإعلان عن المتغيرات ..لأنه في التعامل مع البيانات الكثيرة والأكواد الكبير يلزم الإعلان عنها للتخفيف على الذكراة أثناء التنفيذ ..نريد أن نعود أنفسنا الخطوات الصحيحة (والكلام موجه لي ولك ولجميع الأعضاء)

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

تعمدت استخدام رسائل التنبيه التي يمكن الاستغناء عنها لتنبيه المستخدم إذا ما كان السجل تم ترحيله من قبل وهذا تعديل على السابق أو أنه سجل جديد أو أنه لم تتم عملية الترحيل ..ويمكن كما ذكرت الاستغناء عنها لتخفيف الكود

أمر آخر بالنسبة للإعلان عن المتغيرات ..صراحة لا أحبذ استخدام اللغة العربية في أسماء المتغيرات أو تعيين قيم المتغيرات إذ أن اللغة العربية تكون مربكة في التعامل مع الكود فأفضل أن يتم الإعلان عن المتغيرات في بداية الكود ثم بدء التعامل معها .. وأفضل تسمية المتعيرات الخاصة بأوراق العمل بأسمائها البرمجية Sheet1 , Sheet2 إلا إذا كانت باللغة العربية ورقة1 و وورقة2 في هذه الحالة أتعامل مع أسماء أوراق العمل بشكل مباشر

..

أمر آخر في الكود الأخير الخاص بك .. ماذا لو تم تنفيذ الكود وأنت في ورقة العمل "كشف" بالطبع سيحدث خطأ إذا أنك لم تشر إلى ورقة العمل التي سيتم جلب البيانات منها وهي ورقة "الإدخال" ولن تتم عملية الترحيل بشكل صحيح إلا إذا كنت محدد ورقة العمل "الإدخال"

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

تقبل وافر تقديري واحترامي

[رجب جاويش]

أخى الحبيب ياسر

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

كما أتفق معك فى تلافي الترحيل في حالة أن رقم الإيصال فارغ 

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

فى طلبه

بجد انت كدا حمستنى للعودة بقوة الى مدرسة الاكسل

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

أنا صاحى معاك أخى الحبيب وعلى استعداد للدرس التالى

تحياتى لك أخى الحبيب

 

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

أخي ومعلمي الكبير رجب

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

تقبل وافر تقديري واحترامي