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

[محمد يوسف]

اساتزه وخبراء هذا المنتدي  جزاكم الله خيراً

بحثت كثير في المنتدي ولم اجد ما اريدة 

هل يوجد مساعدة من الاخوه الافاضل لأهميه الموضوع الخاص بي

انا محتاج هذا الكود ضروري 

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

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

Sub export_data()
        Dim MOKHTAR As Workbook
    Dim mokhtar4 As Workbook
       Dim lr2
  Dim arr
    Application.ScreenUpdating = False
        Set MOKHTAR = ActiveWorkbook
           Set mokhtar4 = Workbooks.Open("d:/INPOTEXCELL/mokhtar4.xls")
          MOKHTAR.Range("c2,c3,c4,c5:,d5,g1,g2").Copy
    With mokhtar4.Sheets(1).Range("A1").Range("a" & Sheets("Sheet1").[a65536].End(xlUp).Row + 1)
        .PasteSpecial xlValues
        .PasteSpecial xlFormats
           End With
       Application.Quit
  End Sub

يوجد خطأ  في هذا الستر   ولم اعرفه     

MOKHTAR.Range("c2,c3,c4,c5:,d5,g1,g2").Copy

                

INPOTEXCELL.rar

[عبدالفتاح في بي اكسيل]

 

لماذا   لا  تجعل   المدى  من c2:c5جرب هذا  التعديل 

MOKHTAR.Range("c2:c5,d5,g1,g2").Copy

 

[محمد يوسف]

استاذى الكبير عبدالفتاح في بي اكسيل 

 

شكراً علي سرعة الرد

 

بالفعل نفذت ما ذكرته

ولكن يظهر لي خطأ 

[محي الدين ابو البشر]

ممكن أ ن تستبدله بـ

Set Rng = Union(Range("c2:c5"), Range("d5"), Range("g1:g2"))
Rng.select

 

[محمد يوسف]

استاذ محي الدين ابو البشر  جزاك الله خيراً

يوجد خطأ

ممكن بعد اذن حضرتك توفقة مع الملف لو امكن  ................  الباسورد  123

mokhtar4.xls الملف الرئيسي.xlsm

[محمد يوسف]

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

بحيث اني اريد ترحيل الخلاية المحددة

ولكن بيظهر  رسالة  خطأ

احبتي في الله انا محتاج هذا الكود ضروري

عملي و شغلي  يتطلب  هذا الكود

ارجو المساعده  

شكراً  لمن حاول يساعدني 

 

[احمدزمان]

في ٤‏/١١‏/٢٠٢٠ at 18:08, محمد يوسف said:

يوجد خطأ  في هذا السطر   ولم اعرفه     

MOKHTAR.Range("c2,c3,c4,c5:,d5,g1,g2").Copy

لا اظن ان الخطأ هنا

اعتقد ان الخطأ يكون هنا

في ٤‏/١١‏/٢٠٢٠ at 18:08, محمد يوسف said:

Set mokhtar4 = Workbooks.Open("d:/INPOTEXCELL/mokhtar4.xls"

حيث ان هنا هذا التعريف هو لفتح الملف
ثم انت استخدمته كـ اسم للملف

لذلك

استبدل  هذا السطر Set mokhtar4 = Workbooks.Open("d:/INPOTEXCELL/mokhtar4.xls"

بما يلي

Workbooks.Open("d:/INPOTEXCELL/mokhtar4.xls")
Set mokhtar4 = ActiveWorkbook

ان شاء الله رايحة تظبط معاك

فضلا جرب و اعلمني بالنتيجة .... مع التحية

 

[احمدزمان]

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

كلامك صحيح يوجد خطأ هنا

لم تراعي التسلسل في النطاق

يجب ان يكون = اسم الملف . اسم الورقة . اسم النطاق الخلايا

بينما انت وضعت اسم الملف . ثم نطاق الخلايا ==== بدون اسم الورقة

وهذا خطأ

 

[احمدزمان]

 

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

لذلك اذافهمنا منك ماهو المطلوب فعلا

ممكن ان يتم تجزئة النطاق الى اجزاء و نقلها للمكان الذي تريده

تحياتي

مختار.rar

[محمد يوسف]

استاذنا الكبير احمدزمان   بجد شكرا علي طول بالك معي 

وانا اسف علي كثرة طلبي 

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

استاذي احمدزمان   عجز لساني عن شكرك  اسأل الله ان يجزيك به خيراً

شرح اوضح مختار.rar

[احمدزمان]

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

اولا : 

تضع اسم الملف المراد فتحه و المسار كاملا في الخلية J2 في الملف الرئيسي

ثانيا :

هذا الكود لعمل اللازم - على قدر فهمي لطلبك

Sub az_mokhtar()
'نقل البيانات
Dim WB1 As Workbook, WB2 As Workbook
Dim FS As Worksheet, TS As Worksheet
Dim Q1, TR
Set WB1 = Workbooks(ActiveWorkbook.Name)
Set FS = WB1.Sheets(ActiveSheet.Name)
Q1 = FS.Range("J2").Text
Workbooks.Open (Q1)
'Workbooks.Open "C:\Users\Ad\Desktop\مختار\mokhtar4 (1).xls"
Set WB2 = Workbooks(ActiveWorkbook.Name)
Set TS = WB2.Sheets(1)
TR = TS.[a65536].End(xlUp).Row + 1
''
TS.Cells(TR, 1) = FS.Cells(1, 2)
TS.Cells(TR, 2) = FS.Cells(2, 3)
TS.Cells(TR, 3) = FS.Cells(5, 4)
TS.Cells(TR, 4) = FS.Cells(3, 3)
TS.Cells(TR, 5) = FS.Cells(4, 3)
TS.Cells(TR, 6) = FS.Cells(5, 3)
TS.Cells(TR, 7) = FS.Cells(1, 7)
TS.Cells(TR, 8) = FS.Cells(2, 7)
'With TR
'        .PasteSpecial xlValues
'        .PasteSpecial xlFormats
'           End With
WB2.Save
WB2.Close
FS.Activate

End Sub

جرب المرفق

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

 

مختار.rar

[محمد يوسف]

استازى الكبير  احمدزمان   

طلب اخير لو امكن 

هل من الممكن عندما يوجد نفس اسم  العميل يتم تحديث بيناته يعني استبدال البينات - بدل تكرار اسم وبيانات العميل

شكراً لحضرتك وجزاك الله خيراً

[احمدزمان]

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

 

تم عمل المطلوب 

مع رسالة عند تكرار الاسم

Sub az_mokhtar()
'äÞá ÇáÈíÇäÇÊ
Dim WB1 As Workbook, WB2 As Workbook
Dim FS As Worksheet, TS As Worksheet
Dim Q1, Q2, TR, TR2
Set WB1 = Workbooks(ActiveWorkbook.Name)
Set FS = WB1.Sheets(ActiveSheet.Name)
Q1 = FS.Range("J2").Text
Workbooks.Open (Q1)
'Workbooks.Open "C:\Users\Ad\Desktop\ãÎÊÇÑ\mokhtar4 (1).xls"
Set WB2 = Workbooks(ActiveWorkbook.Name)
Set TS = WB2.Sheets(1)
TR = TS.[a65536].End(xlUp).Row + 1
''
Q2 = FS.Cells(1, 2).Text
For TR2 = 2 To TR
If TS.Cells(TR2, 1) = Q2 Then
MsgBox "ãæÌæÏ: " & Q2 & " - - ÕÝ= " & TR2
TR = TR2
GoTo 7
End If
Next
''
7
TS.Cells(TR, 1) = FS.Cells(1, 2)
TS.Cells(TR, 2) = FS.Cells(2, 3)
TS.Cells(TR, 3) = FS.Cells(5, 4)
TS.Cells(TR, 4) = FS.Cells(3, 3)
TS.Cells(TR, 5) = FS.Cells(4, 3)
TS.Cells(TR, 6) = FS.Cells(5, 3)
TS.Cells(TR, 7) = FS.Cells(1, 7)
TS.Cells(TR, 8) = FS.Cells(2, 7)
WB2.Save
WB2.Close
FS.Activate

End Sub

شاهد المرفق 

مع التحية

مختار.rar

[محمد يوسف]

استاذ  احمدزمان   رائع جداً

هذا هو المطلوب واكثر بكتير 

استاذ احمدزمان  اسأل الله العلي القدير ان يبارك لك في علمك ويبارك لك في اولادك ويبارك لك في صحتك ويبارك لك في مالك

اخي في الله  ربي يجازيك خير الجزاء اللهم امين يارب العالمين

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

[احمدزمان]

آمين يارب انا و انت و جميع المسلمين

شكرا لك على هذه الدعوات الجميله

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