خطأ فى دمج كودين ترحيل نرجو فضلا التصويب

[أبو عبد الرحمن سعيد]

بسم الله الرحمن الرحيم

وبه نستعين

اخوانى الافاضل

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

مع دمج الكودين الموضحين أمام حضراتكم وهما لآخى الحبيب الاستاذ الفاضل

ياسر خليل ابو البراء

حدث خلل فى عملية الترحيل

الكود الاول

Sub TransferMatchingData()
    Dim WS As Worksheet, SH As Worksheet
    Dim Cel As Range, Found As Range
    
    Set WS = Sheet1: Set SH = Sheet3
    
    Application.ScreenUpdating = False
        On Error Resume Next
        For Each Cel In WS.Range("B8:B" & WS.Cells(Rows.Count, "B").End(xlUp).Row)
            Set Found = SH.Range("B:B").Find(What:=Cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            
            If Not Found Is Nothing And Not IsEmpty(Cel.Value) Then
                Found.Offset(, 1).Resize(1, 2).Value = Cel.Offset(, 1).Resize(1, 2).Value
            End If
            
        Next Cel
    Application.ScreenUpdating = True
End Sub

الكود الثانى

Sub TransferDataUsingFilterMethod()
    Dim WS As Worksheet, SH As Worksheet
    Dim LR As Long, LastRow As Long
    Dim X As Long, I As Long
    
    Set WS = Sheet1: Set SH = Sheet5
    LR = WS.Cells(Rows.Count, 1).End(xlUp).Row
    LastRow = SH.Cells(Rows.Count, "D").End(xlUp).Row + 1
    
    Application.ScreenUpdating = False
        With WS
            .AutoFilterMode = False
            .Range("A7:D7").AutoFilter Field:=3, Criteria1:="<>" & ""
            
            .Range("B8:D" & LR).SpecialCells(xlCellTypeVisible).Copy
            SH.Cells(LastRow, "D").PasteSpecial xlPasteValues
            
            SH.Cells(LastRow, "B").Value = WS.Range("B6").Value
            SH.Cells(LastRow, "C").Value = WS.Range("C3").Value
            
            .AutoFilterMode = False
        End With
    
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
    
    MsgBox "Done...", vbInformation, "YasserKhalil"
End Sub

المطلوب بحول الله تعالى

ترحيل عمود سعر الشراء بالعمودD  بصفحة الوارد الى العمود F  بالصفحة الرئيسية

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

ترحيل الاعمدة  من B  الى العمود D  من صفحة الوارد  الى صفحة حركة الاصناف بالاعمدة من E  الى G

وافر تقديرى واحترامى وجزاكم الله خيرا

ترحيل بيانات فاتورة.xlsb.rar

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

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

أخي الكريم سعيد بيرم

لم أطلع على الملف بعد فوقتي ضيق للغاية ، ولكن لي سؤال ماذا تقصد بدمج الكودين ؟ هل تريد تنفيذ الكودين بشكل متتالي ؟ أم أنك تريد مطلوب جديد بشكل جديد يعتمد على الكودين؟

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

تقبل تحياتي

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

نقطة أخرى

الكلام مش مفهوم بالنسبة لي كما أخبرتك من قبل

كلامك كالتالي :

15 ساعات مضت, سعيد بيرم said:

ترحيل عمود سعر الشراء بالعمودD  بصفحة الوارد الى العمود F  بالصفحة الرئيسية

ولما نظرت للورقة الرئيسية وجدت أن عمود سعر الشراء يقع بالعمود D أيضاً وليس بالعمود F ، بينما العمود F فيه الإجمالي ..

يراعى الدقة في التوضيح واعذرني لقلة وقتي

[أبو عبد الرحمن سعيد]

اخى الغالى  ابو البراء

السلام عليكم

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

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

لتنفيذهما بزرواحد حدث هذا الخلل **** برجاء الاطلاع على المرفق " الاعمدة المظلله باللون الرمادى "

ترحيل عمود سعر الشراء بالعمودF  بصفحة الوارد الى العمود F  بالصفحة الرئيسية

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

 فى انتظاركم أخى الحبيب ******* وافر تقديرى واحترامى وجزاكم الله خيرا

ترحيل بيانات فاتورة+1111111.xlsb.rar

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

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

أخي الكريم سعيد بيرم

يبدو أننا لم نصل لاتفاق بعد في موضوع توضيح المطلوب ..

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

عموماً جرب الكود التالي عله يفي بالغرض

Sub TransferMatchingData()
    Dim Ws1 As Worksheet, Ws2 As Worksheet, Ws3 As Worksheet
    Dim Cel As Range, Found As Range
    Dim LR As Long, LastRow As Long
    Dim X As Long, I As Long
    
    Set Ws1 = Sheet1: Set Ws2 = Sheet2: Set Ws3 = Sheet3
    
    Application.ScreenUpdating = False
        On Error Resume Next
        LR = Ws1.Cells(Rows.Count, 1).End(xlUp).Row
        LastRow = Ws3.Cells(Rows.Count, "E").End(xlUp).Row + 1
        
        For Each Cel In Ws1.Range("B8:B" & LR)
            Set Found = Ws2.Range("B:B").Find(What:=Cel.Value, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            If Not Found Is Nothing And Not IsEmpty(Cel.Value) Then
                Found.Offset(, 1).Value = Cel.Offset(, 1).Value
                Found.Offset(, 4).Value = Cel.Offset(, 4).Value
            End If
        Next Cel
        
        With Ws1
            .AutoFilterMode = False
                .Range("A7:D7").AutoFilter Field:=3, Criteria1:="<>" & ""
                
                .Range("B8:C" & LR).SpecialCells(xlCellTypeVisible).Copy
                Ws3.Cells(LastRow, "E").PasteSpecial xlPasteValues
                .Range("F8:F" & LR).SpecialCells(xlCellTypeVisible).Copy
                Ws3.Cells(LastRow, "G").PasteSpecial xlPasteValues
                
                Ws3.Cells(LastRow, "B").Value = Ws1.Range("B6").Value
                Ws3.Cells(LastRow, "D").Value = Ws1.Range("F6").Value
                Ws3.Cells(LastRow, "C").Value = Ws1.Range("C3").Value
            .AutoFilterMode = False
        End With
        
        Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox "Done...", vbInformation, "YasserKhalil"
End Sub

تقبل تحياتي

 

[أبو عبد الرحمن سعيد]

أخى الحبيب الغالى المحترم // ابو البراء

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

تسلم من كل شر ودامت دياركم عامرة بالسعادة

وربنا بديك الصحة والعافية ***** جزاكم الله خيرا

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

 

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

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

أخي وحبيبي في الله سعيد

في ردك الأخير دعوت لي دون ذكر هل تم المطلوب على خير أم أنه ما زالت هناك بعض الشوائب .. اذكر الشوائب الآن لا غداً فربما لن تجدني بعد الآن ...ربما أسافر غداً لمدة لا يعلمها إلا الله

جزيت خيراً بمثل ما دعوت لي

تقبل تحياتي