تصحيح كود ترحيل من ملف الى آخر

[خير الايمان]

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

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

مرفق ملف به مستندين والمراد عند اضافة بيانات بالمستند ( 2 ) والضغط على زر الترحيل يتم الترحيل الى المستند ( 1 )

حاولت ذلك من خلال كود لكن دون جدول 

برجاء المساعدة

تقديري

e.rar

[محمد هشام.]

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

تفضل اخي 

Option Explicit

Sub Transfer()
Dim wbData As Workbook, wsData As Worksheet
Dim rngToCopy As Range, cl As Range
Dim C As Long, LastRow As Long

Dim wsMain As Worksheet: Set wsMain = ThisWorkbook.ActiveSheet

Application.ScreenUpdating = False

Set wbData = Workbooks.Open("C:\Users\Ehab Elhady\Desktop\1.xlsx")

Set wsData = wbData.Sheets("Sheet1")

Set rngToCopy = wsMain.Range("D6,D8,D10,D12,D14,G6,G8,G10,G12,G14")

LastRow = wsData.Cells(wsData.Rows.Count, "A").End(xlUp).Row

C = 1
For Each cl In rngToCopy
    cl.Copy
    wsData.Cells(LastRow + 1, C).PasteSpecial xlPasteValues
    C = C + 1
Next cl

wbData.Close True
Application.CutCopyMode = False
MsgBox " تم ترحيل البيانات  بنجاح", vbInformation, "تعليمات"
    

End Sub

 

 

e_V2.rar

تم تعديل مايو 20 بواسطه Mohamed Hicham

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

وعليمن السلام

بالإذن خيار آخر

Sub test()
Dim a, b: Dim lr&
a = ActiveSheet.Range("D6:D14").Resize(, 4)
ReDim b(1 To 5)
b = Array(1, 3, 5, 7, 9)
Workbooks.Open ("C:\Users\Ehab Elhady\Desktop\1.xlsx")
 With Sheets("sheet1").Cells(1, 1).Resize(, 5)
        lr = .Cells(Rows.Count, 1).End(xlUp).Row
        .Offset(lr).Value = Application.Index(a, b, 1)
        .Offset(lr, 5).Value = Application.Index(a, b, 4)
 End With
 Workbooks("1.xlsx").Close True
End Sub

 

[خير الايمان]

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

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

بارك الله

[محمد ايمن]

في 20‏/5‏/2023 at 11:06, محي الدين ابو البشر said:

Dim lr&

تحية طيبة استاذي الكريم @محي الدين ابو البشر

هل من الممكن شرح هذ السطر ؟

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

محمد أيمن

Dim i& = Dim As Long
Dim x$ = Dim x As String
Dim a =  Dim a As Variant
Dim y% = Dim y As Integer
Dim z# = Dim z As Double
Dim s! = Dim s As Single

بالنتيجة هي اختصارات

[محمد ايمن]

22 ساعات مضت, محي الدين ابو البشر said:

بالنتيجة هي اختصارات

كلما زاد علمي ازداد علمي بجهلي

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

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

ولك مثل ما دعوت

ورارك الله