الترحيل من ملف لملف آخر

[طارق_طلعت]

الأخوة الأعزاء خبراء المنتدى

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

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

و المطلوب هو ان يتم ترحيل القيد الموجود بملف المخزن الى الملف الأخر (حسابات تجهيز) على ان يتم الترحيل بناء عى الكود بالخليتين A13 و A14

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

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

لذلك لجأت إلى الله ثم إليكم لمساعدتى فى ضبط الكود

و شكرا جزيلا على المساعدة المعهودة منكم دائما

الترحيل من ملف الى مف اخر.rar

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

أخي الفاضل طارق

يرجى عدم منادة شخص بعينه فكلنا هنا في المنتدى يد واحدة تبني كلها في صرح المنتدى - لابد أن تعلم ذلك جيداً - ومناداة شخص بعينه قد تنفر عضو لديه الحل من تقديم الحل (وجهة نظر لابد أن تحترم)

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

Sub TransferDataToClosedWB()
    Dim WB As Workbook, SH As Worksheet
    Dim Cell As Range
    Dim LR_A As Long, LR_B As Long

    LR_A = IIf(Cells(Rows.Count, 1).End(xlUp).Row < 13, 13, Cells(Rows.Count, 1).End(xlUp).Row)
    
    Application.ScreenUpdating = False
        If Application.WorksheetFunction.CountA(Range("A13:A" & LR_A)) < 1 Then MsgBox "لا يوجد بيانات لترحيلها", vbInformation: Exit Sub
        
        Set WB = Workbooks.Open(Filename:=ThisWorkbook.Path & "\" & "حسابات تجهيز.xlsm")
        
        For Each Cell In ThisWorkbook.Sheets("ترحيل").Range("A13:A" & LR_A)
            For Each SH In WB.Sheets
                If SH.Name = Cell.Value Then
                    With SH
                        LR_B = IIf(Cells(Rows.Count, 4).End(xlUp).Row < 16, 16, Cells(Rows.Count, 1).End(xlUp).Row + 1)
                        Cell.Offset(, 2).Resize(, 5).Copy
                        .Range("A" & LR_B).PasteSpecial xlPasteValues
                    End With
                End If
            Next SH
        Next Cell
        
        WB.Close SaveChanges:=True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

وإليك الملف المرفق الخاص بك فيه تطبيق الكود

 

لاتنسى التوجيهات بتحديد أفضل إجابة والضغط على كلمة "أعجبني هذا"

تقبل تحياتي

الترحيل من ملف الى مف اخر.rar

[طارق_طلعت]

الأخ العزيز الأستاذ ياسر

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

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

و ايضا اريدة بعد الترحيل ان يفتح على الشيت الأول من الملف حيث انة يفتح على شيت فى منتصف الملف

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

 

و شكرا جزيلا للمساعدة

و اعتذر لك و لجميع الخبراء بالمنتدى مرة اخرى

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

صراحة لن أستطيع تجربة الكود الآن لأن عقلي توقف تقريباً .. فصلت    جرب تغير السطر التالي

LR_B = IIf(.Cells(Rows.Count, 4).End(xlUp).Row < 16, 16, .Cells(Rows.Count, 1).End(xlUp).Row + 1)

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

 

جرب وضع السطر التالي قبل سطر إغلاق المصنف رابع سطر من تحت

WB.Sheets(1).Activate

ليفتح على أول شيت

 

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

 

[طارق_طلعت]

استاذ ياسر

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

قمت بتنفيذ اقتراحك و بالفعل تم تنفيذ الكود كما اريد تماما

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

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

و أسف على الأثقال على حضرتك

و شكرا جزيلا

[اسلام رجب]

الشلام عليكم فيديو بسيط 

[سـامي 169]

اهنئ اهل المنتدى

بالاستاذ الذي لايذكى على الله

الاستاذ اسلام رجب

سيكون ان شاء الله اضافه كبيره للمنتدى

 

جزاك الله كل خيراستاذ اسلام  وبارك لك

[سـامي 169]

فيديو رائع للاستاذ اسلام

لاتحرمنا من شروحاتك يابطل

[اسلام رجب]

تسلم استاذ اسلام ربنا يبارك فيك يارب

[ابا اسماعيل]

جزاك الله كل خيراستاذ اسلام

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

أخي طارق

فقط احذف هذا السطر

WB.Close SaveChanges:=True

[طارق_طلعت]

الاخ العزيز الاستاذ ياسر

بالفعل قمت بحذف السطر المذكور و بالفعل لا يقوم الكود باغلاق الملف بعد الترحيل

ولكن المشكله عند تنفيذ الكود مره اخرى و الملف مفتوح فان الكود يطلب فتح الملف مره اخرى مما يضرنى الى اغلاق الملف يدويا بعد كل قيد ليقوم الكود بفتحه مره اخرى عند تشغيل الكود مما يتطلب مجهود و وقت كبير

و المطلوب ان يتم تنفيذ الكود و الملف مفتوح و لا يطلب فتح الملف مره اخرى مع كل قيد بحيث ان اقوم باغلاقه يدويا بعد الانتهاء من ترحيل جميع القيود

اسف على الاطاله و شكرا للمساعده

[قصي]

 

جزاكم الله خيرا الاستاذ ياسر

والاستاذ اسلام صاحب الفيديو المفيد
 

[اسلام رجب]

تسلم ابا اسماعيل ربنا يبارك فيك يارب

[اسلام رجب]

ربنا يبارك فيك اخى قصي

[اسلام رجب]

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

"Workbooks.Open Filename:="e:\book2.xlsm

 

Windows("book2.xlsm").Activate

 

Workbooks("book2.xlsm").Sheets(1).Range("a1:j" & Cells(Rows.Count, "a").End(xlUp).Row).Copy

 

Workbooks("book1.xlsm").Activate

 

Workbooks("book1.xlsm").Sheets(1).Range("a" & Rows.Count).End(xlUp).Rows.Offset(1, 0).Select

 

Selection.PasteSpecial xlPasteValues

 

Workbooks("book2.xlsm").Save

 

Workbooks("book2.xlsm").Close

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

أخي الفاضل جرب الكود بهذا الشكل

Sub TransferDataToClosedWB()
    Dim WB As Workbook, SH As Worksheet
    Dim Cell As Range
    Dim strWB As String
    Dim LR_A As Long, LR_B As Long

    LR_A = IIf(Cells(Rows.Count, 1).End(xlUp).Row < 13, 13, Cells(Rows.Count, 1).End(xlUp).Row)
    strWB = ThisWorkbook.Path & "\" & "حسابات تجهيز.xlsm"
    
    Application.ScreenUpdating = False
        If Application.WorksheetFunction.CountA(Range("A13:A" & LR_A)) < 1 Then MsgBox "لا يوجد بيانات لترحيلها", vbInformation: Exit Sub
        
        On Error Resume Next
        
        If FileInUse(strWB) Then
            Set WB = Workbooks("حسابات تجهيز.xlsm")
        Else
            Set WB = Workbooks.Open(Filename:=strWB)
        End If
        
        For Each Cell In ThisWorkbook.Sheets("ترحيل").Range("A13:A" & LR_A)
            For Each SH In WB.Sheets
                If SH.Name = Cell.Value Then
                    With SH
                        LR_B = IIf(.Cells(Rows.Count, 4).End(xlUp).Row < 16, 16, .Cells(Rows.Count, 1).End(xlUp).Row + 1)
                        Cell.Offset(, 2).Resize(, 5).Copy
                        .Range("A" & LR_B).PasteSpecial xlPasteValues
                    End With
                End If
            Next SH
        Next Cell
    WB.Sheets(1).Activate
    ThisWorkbook.Activate
    
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

Public Function FileInUse(sFileName) As Boolean
    On Error Resume Next
    Open sFileName For Binary Access Read Lock Read As #1
    Close #1
    FileInUse = IIf(Err.Number > 0, True, False)
    On Error GoTo 0
End Function

تقبل تحياتي

[علاء رسلان]

الشلام عليكم فيديو بسيط 

السلام عليكم

الأخ الكريم اسلام رجب بالأطلاع على ملفك الشخصى اتضح لى كونك عضو بالمنتدى منذ فبراير 2014 و عدد مشاركاتك بالمنتدى لا يتعدى 20 مشاركة حتى لحظة كتابة السطور

بالـتأكيد تعد مكسبا للمنتدى و إضافة مميزة بالتفاعل مع الاعضاء و مشاركتهم  فى المواضيع و هو أمر جيد و حتى يكون تواجدك متسق مع المنتدى أذكرك بأمرين هامين

فضلا لا أمرا أولا عليك الأطلاع على التوجيهات الخاصة بالأعضاء الجدد من هنا http://www.officena.net/ib/index.php?showtopic=60147

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

[اسلام رجب]

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

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

أخي الحبيب علاء رسلان

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

 

الأخ الكريم المتميز والمبدع إسلام رجب

بالفعل تواجدك معنا مكسب لنا جميعاً وننتظر منك موضوعات مميزة تقدمها لنا بأسلوبك الفريد المميز

 

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

[اسلام رجب]

ربنا يبارك فيك استاذ ياسر دى من ذوقك الكريم الطيب

[طارق_طلعت]

الأخ العزيز الأستاذ ياسر

 

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

ان ملف (حسابات تجهيز) بة كود يقوم بتسمية الشيتات تلقائيا بناء على محتوى الخلية C6 بكل شيت من نفس الملف

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

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

 

و شكرا جزيلا استاذ ياسر لوقتك و مجهودك

الترحيل من ملف الى اخر.rar

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

أخي الفاضل طارق

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

بالموضوع الجديد يمكن للأخوة الأعضاء أن يساهموا بالمساعدة قدر الإمكان وإن شاء الله إذا وجدت متسع من الوقت سأقوم بالإطلاع على الموضوع بشكل مؤكد

تقبل تحياتي

[اسلام رجب]

بالتوفيق

تم تعديل يوليو 14, 2015 بواسطه اسلام رجب

[طارق_طلعت]

استاذ ياسر

انا شاكر جدا و مقدر مجهودك العظيم

و لا اريد ان اثقل عليك و يكفى ما اعطيتنى من وقت و مجهود

و ادعوا الساده الخبراء الافاضل لمراجعه الكود و مساعدتى فى حل المشكله

مره اخرى شكرا للاستاذ ياسر و لجميع الخبراء

و كل عام و انتم بخير