طلب المساعدة فى استيراد بيانات من ملف اكسل

[عبدالرحمن بدوى]

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

تحية طيبة وبعد

كما فى المرفق لدى ملفان اكسل 1و2

وفى الملف 1 توجد مجموعة من البيانات اسم سن رقم ......

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

وايضا لا يتم فتح ملف واحد اثناء استيراد البيانات

وبالطبع فإن ملف 1 و 2 لن يكونو فى نفس المسار على الجهاز

انا بحثت على النت ووجدت كود ولكنى لم استطع استخدامه لا ادرى ما السبب

فالكود يقوم فقط باستدعاء البيانات فى ملف فى الخلية a1 فقط

 

الكود

Sub Read_External_Workbook()

 

    '''''Define Object for Target Workbook

    Dim Target_Workbook As Workbook

    Dim Source_Workbook As Workbook

    Dim Target_Path As String

    

    '''''Assign the Workbook File Name along with its Path

    '''''Change path of the Target File name

    Target_Path = "D:\Sample.xlsx"

    Set Target_Workbook = Workbooks.Open(Target_Path)

    Set Source_Workbook = ThisWorkbook

    

    '''''With Target_Workbook object now, it is possible to pull any data from it

    '''''Read Data from Target File

    Target_Data = Target_Workbook.Sheets(1).Cells(1, 1)

    Source_Workbook.Sheets(1).Cells(1, 1) = Target_Data

    

    '''''Update Target File

    Source_data = Source_Workbook.Sheets(1).Cells(3, 1)

    Target_Workbook.Sheets(1).Cells(2, 1) = Source_data

    

    '''''Close Target Workbook

    Source_Workbook.Save

    Target_Workbook.Save

    Target_Workbook.Close False

    

    '''''Process Completed

    MsgBox "Task Completed"

    

End Sub

 

 

وإن امكن نقوم يقوم الكود ايضا بمسح البيانات من ملف 1 بعد استيرادها فى ملف 2

 

ولكم جزيل الشكر

work.rar

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

الأخ الكريم عبد الرحمن

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

يوجد في المنتدى موضوع مشابه تماماً لطلبك فقط تعديل بسيط ليتم المطلوب

إليك الكود بشكل منضبط ليظهر بشكل يسهل على الأعضاء الإطلاع عليه

Sub ImportData()
    Dim WB As Workbook, myRng As Range
    Dim myRow As Long
    Dim shMain As Worksheet
    
    Application.ScreenUpdating = False
    Set shMain = ThisWorkbook.ActiveSheet

    Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "1.xlsx")
    Set myRng = WB.ActiveSheet.Range("D12:G" & WB.ActiveSheet.Cells(Rows.Count, 4).End(xlUp).Row)
    
    On Error Resume Next
    With shMain
        myRng.Copy
        .Range("D12").PasteSpecial xlPasteValues
    End With
    
    myRng.ClearContents
    WB.Close True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub

يوضع الكود في المصنف رقم 2 والمراد استيراد البيانات إليه ثم يتم مسح البيانات من المصنف رقم 1 كما طلبت

 

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

 

تقبل تحياتي

Work.rar

[عبدالرحمن بدوى]

اخى الفاضل

جزاكم الله خيرا على سرعة الإستجابة

واعتذر ان كنت كررت الموضوع عن غير عمد

لأنى بحثت فى المنتدى فلم أجد

وبالفعل الكود هو ما اريده بالضبط فقد أجبت ووفيت

ولكن لى استفسارات بسيطة فى الكود

اولا لو مثلا الملف 1 فى مسار اخر مثل (d/newfolder/1.xlsx)

اين يوضع التعديل

 

وايضا الملف 1 به اكثر من شيت ولك شيت باسم معين

كيف يتم تحديد ذلك فى الكود

 

وبعد انتهاء العملية تظهر لي رسالة لإثبات اكتمال العملية

كما فى الكود السابق

 

 

انا عارف انى كثرت فى الأسئلة ولكن اعذرنى

تم تعديل يوليو 23, 2015 بواسطه عبدالرحمن بدوى

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

هذا السطر للتعديل في مسار المصنف

Set WB = Workbooks.Open(ThisWorkbook.Path & "\" & "1.xlsx")

هتشيل الجزء التالي

ThisWorkbook.Path

وتضع مسار المصنف بين أقواس تنصيص

 

***************************

 

بالنسبة لو هتتعامل مع ورقة عمل أخرى يمكنك التعديل في الجزء ActiveSheet

WB.ActiveSheet

بأن تستخدم كلمة Sheets ثم افتح قوس ثم علامات تنصيص وتكتب اسم ورقة العمل ثم تغلق علامات التنصيص ثم تغلق الأقواس

Sheets("Data")

بفرض أن ورقة العمل اسمها Data

 

************************

 

بالنسبة للرسالة ضعها في السطر قبل السطر الأخير

End Sub

[عبدالرحمن بدوى]

تمام يا استاذ ياسر خليل ابو البراء

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

وهذا ما كنت اطلبه بالضيط

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

وهو اختيار اعمدة معينة فى استيراد البيانات وليس اعمدة متجاورة كما فى المعتاد

ففى المرفق فى ملف 1 كتبت مجموعة من البيانات وسميت كل عمودة باسم result 1 , result 2 ,result 3.......

وهكذا وانا اريد ان اعدل فى الكود ليتم استيراد البيانات الموجودة فى result 1.3.5.6

الممثلة فى الأعمدة c , e , k & L

والادراج فى ملف 2 فى اعمدة متجاورة عادى كما بالمرفق

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

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

Work.rar

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

أخي الكريم

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

حاول تراعي وقت وجهد الآخرين بالله عليك

 

أمر آخر ...هل الملف رقم معبر عن شكل الملف الأصلي ؟؟ إذ لاحظت أنه في الصف رقم 11 أن هناك عناوين موجودة مرتين result5 و result6 (هذا غير معبر بعض الشيء) ..كما أن هناك عناوين مختلفة عن العناوين في الملف رقم 2  ... هناك عنوان result 5 يوجد مسافة بين الكلمة والرقم

عموماً قمت بمسح العناوين في العمود Gو H في الملف رقم 1 كما قمت بإزالة المسافة بين الكلمة والرقم في الملف رقم 1 أيضاً ليعمل الكود بشكل جيد

حيث أن الكود الآن يعتمد على عناوين الصف رقم 14 في الملف رقم 2 ، وعناوين الصف رقم 11 في الملف رقم 1 ، ليتم جلب البيانات في المكان المناسب من المكان المناسب

 

إليك الكود التالي لعله يفي بالغرض

Sub ImportData()
    Dim WB As Workbook, myRng As Range, Cell As Range
    Dim myRow As Long, lCol As Long
    Dim shMain As Worksheet

    Application.ScreenUpdating = False
    Set shMain = ThisWorkbook.ActiveSheet

    Set WB = Workbooks.Open("G:\1.xlsx")

    On Error Resume Next
    For Each Cell In shMain.Range("C14:F14")
        With WB.Sheets("Data")
            lCol = Application.WorksheetFunction.Match(Cell, .Rows(11), 0)
            Set myRng = WB.Sheets("Data").Range(.Cells(12, lCol), .Cells(.Cells(Rows.Count, lCol).End(xlUp).Row, lCol))
            myRng.Copy
            shMain.Cells(15, Cell.Column).PasteSpecial xlPasteValues
        End With
    Next Cell

    WB.Close True
    Application.CutCopyMode = False
    Application.ScreenUpdating = True

    MsgBox "Task Completed"
End Sub

ملحوظة يوضع الملف رقم 1 في المسار المكتوب في الكود في البارتشن G

وإليك الملف المرفق

Work.rar

[عبدالرحمن بدوى]

اخى الفاضل

جزاكم الله خيرا على الافادة

وأسأل الله ان يجعل ذلك فى ميزان حسناتك

وأعتذر على الإطالة وعلى عدم كتابة تاموضوع بالشكل المطلوب من البداية 

ولكنى بالطبع لم أقصد ذلك نهائيا

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

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

وأخيرا جزاكم الله خيرا على المجهود والإفادة

لأن هذا الكود سيساعدنى فى العمل بشكل كبير جدا

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

حتى يعلم الناس بان الموضوع تمت الإجابة عليه ويستفيد الجميع

واعتذر مرة اخرى على ما بذلت معى من مجهود ولكنه كان بغير قصد ولقلة خبرتى بمجال الإكسل

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

أخي الحبيب عبد الرحمن

لا داعي للاعتذار

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

 

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

هذا هو الأسلوب الذي أرغب من الأعضاء اتباعه

 

والحمد لله أن تم المطلوب على خير وتأكد أننا لن نبخل بما لدينا من علم ولن نبخل بوقت ولا بجهد

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