ترحيل من ملف إلى ملف اكسيل

[أحمد علي (أبوعلي)]

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

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

عندي سؤال واحد وبعون الله سأجد الحل عندكم ...
سؤالي هو هل من الممكن كود أن يرحل بيانات من ورقة في الاكسيل إلى ورقة أخرى في ملف اكسيل آخر ؟
كما أني أرسلت ملف للتطبيق

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

أخوكم
أحمد علي 

 

Bjn3000.rar

[أحمد علي (أبوعلي)]

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

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

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

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

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

أخوكم
أحمد علي 

[عبدالله باقشير]

السلام عليكم

جرب هذ

Sub Macro1()
Dim wo1 As Workbook
Dim sh1 As Worksheet
Dim R As Integer
Dim Last As Long
''''''''''''''''''''
Set wo = Workbooks("Book2")
Set sh = wo.Worksheets("Book2")
''''''''''''''''''''
With sh
    For R = 1 To 35
        If WorksheetFunction.CountIf(Range("B8").Cells(R, 1).Resize(1, 6), "<>") = 6 Then
            Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Cells(Last, "A").Value = Range("D5").Value
            .Cells(Last, "B").Value = Date
            .Cells(Last, "C").Resize(1, 6).Value = Range("B8").Cells(R, 1).Resize(1, 6).Value
        End If
    Next
End With
''''''''''''''''''''
Set wo = Nothing
Set sh = Nothing
End Sub

المرفق 2010

Bjn3000.rar

تحياتي

[أحمد علي (أبوعلي)]

جزاك الله عني وعن كل من استفاد من المنتدي ألف خير

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

ولكن يالأستاذ/ عبدالله باقشير

الملف تم ترحله ولكن يوجد بعض الشروط لم تتم:

1. خانة   Source Number    لم تتغير والمطلوب يزيد +1

2. لم يتم مسح البيانات من الجدول في نطاق [b8:G42] بعد الترحيل .

 

والعفو منك، وفي مِيازين حسناتك إن شاء الله

أخوك:

أحمد علي

[عبدالله باقشير]

السلام عليكم

جرب هذا

Sub Macro1()
Dim wo As Workbook
Dim sh As Worksheet
Dim R As Integer, RR As Integer
Dim Last As Long
''''''''''''''''''''
On Error GoTo 1
Set wo = Workbooks("Book2")
Set sh = wo.Worksheets("Book2")
''''''''''''''''''''
With sh
    For R = 1 To 35
        If WorksheetFunction.CountIf(Range("B8").Cells(R, 1).Resize(1, 6), "<>") = 6 Then
            Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Cells(Last, "A").Value = Range("D5").Value2
            .Cells(Last, "A").NumberFormat = "13-00000"
            .Cells(Last, "B").Value = Date
            .Cells(Last, "C").Resize(1, 6).Value = Range("B8").Cells(R, 1).Resize(1, 6).Value
            RR = RR + 1
        End If
    Next
    
End With
'''''''''''''''''''''
If RR Then
    Range("D5").Value2 = Val(Range("D5")) + 1
    Range("B8:G42").ClearContents
End If
''''''''''''''''''''
1:
If Err Then MsgBox Err.Number
Set wo = Nothing
Set sh = Nothing
End Sub

تحياتي

[أحمد علي (أبوعلي)]

السلام عليكم

وبارك الله فيك يا أستاذ/ عبدالله

ويعطيك عافية على الجهود المبذله 

 

أخي الاستاد/ عبدالله  الكود الأخير قام بالمطلوب وجزاك الله خير

 

ولكـن ملاحـظ أن الترحيل مرتبط بشرط أن يكون الملف [book2] مفتوحاً

طـيب بنسبة لملف [book2] لا أحب أن يفتح مـن قبل المستخدم حتى يرحل

هـل من الممكن أن يـتـم تعديل الكود بحيث قبل الترحيل يقوم بفتح الملف ثـم

الترحيل وبعدها يقوم بحفظ الملف ثم الإغلاقة والمقصود بالملف [Book2]

 

مع خالص الشكر والتقدير .....

[عبدالله باقشير]

السلام عليكم

جرب هذا

Sub Macro1()
Dim wo1 As Workbook, wo2 As Workbook
Dim sh As Worksheet
Dim MyPath As String
Dim R As Integer, RR As Integer
Dim Last As Long
''''''''''''''''''''
On Error GoTo 1
Application.ScreenUpdating = False
''''''''''''''''''''
Set wo1 = ThisWorkbook
MyPath = wo1.Path & Application.PathSeparator & "Book2.xlsm"
Set wo2 = Workbooks.Open(MyPath)
Set sh = wo2.Worksheets("Book2")
''''''''''''''''''''
wo1.Activate
With sh
    For R = 1 To 35
        If WorksheetFunction.CountIf(Range("B8").Cells(R, 1).Resize(1, 6), "<>") = 6 Then
            Last = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Cells(Last, "A").Value = Range("D5").Value2
            .Cells(Last, "A").NumberFormat = "13-00000"
            .Cells(Last, "B").Value = Date
            .Cells(Last, "C").Resize(1, 6).Value = Range("B8").Cells(R, 1).Resize(1, 6).Value
            RR = RR + 1
        End If
    Next
    
End With
'''''''''''''''''''''
If RR Then
    Range("D5").Value2 = Val(Range("D5")) + 1
    Range("B8:G42").ClearContents
End If
''''''''''''''''''''
1:
wo2.Close True
Application.ScreenUpdating = True
If Err Then MsgBox Err.Number
Set wo1 = Nothing
Set wo2 = Nothing
Set sh = Nothing
End Sub

تحياتي

[محمود رواس]

ماشاء الله تبارك الله استاذنا ومعلمنا الفاضل عبدالله باقشير الله يزيدك من علمه وفضله وان شاء الله نستفيد من علمك .

[عبدالله باقشير]

ماشاء الله تبارك الله استاذنا ومعلمنا الفاضل عبدالله باقشير الله يزيدك من علمه وفضله وان شاء الله نستفيد من علمك .

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

تقبلوا تحياتي وشكري

[أحمد علي (أبوعلي)]

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

 

أخي الأستاذ/ عبدالله باقشير

جزاك الله خير وبارك فيك وزادك في العلم آمين