إلى أساتذتي وإخوتي الرجاء التعديل في هذا الكود

[ريان أحمد]

السلام عليكم

المشكلة في نوع الملف

عندما إخترت الملف QTT01_04.11 لا يقبله لأنه من نوع bdf4 وليس xls

والصورة المرفقة توضح دلك

ثاني شيئ في ملف tahar الذي يحتوي على الكود في ورقة 01 وورقة 02 أريد الكود يقوم بنسخ إلى ورقة 01وليس الورقة التي فيها الكود

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

tahar.rar

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

السلام عليكم

عندما إخترت الملف QTT01_04.11 لا يقبله لأنه من نوع bdf4 وليس xls

الكود يتعامل مع ملفات الاكسل التي من نوعية نوع الملف "xls"

في ملف tahar الذي يحتوي على الكود في ورقة 01 وورقة 02 أريد الكود يقوم بنسخ إلى ورقة 01وليس الورقة التي فيها الكود

في بداية الكود ضع اسم الورقة التي تريد

لصق البيانات فيها

Const MySheet_Post As String = "post"

وهذا الكود المستخدم:

Option Explicit

Option Compare Text

'  اسم الورقة التي سيتم لصق البيانات فيها

Const MySheet_Post As String = "post"

'


Sub kh_copy_mydate()

    Dim sh As Worksheet

    Dim MyFilOpen As String, MyPath As String, MyBook As String

    '=====================

    On Error GoTo Err_mydate

    '=====================

    Set sh = ActiveWorkbook.Worksheets(ActiveSheet.Name)

    Application.ScreenUpdating = False

    '=====================

    With sh

        MyPath = CStr(.Range("C1")) & ":\" & CStr(.Range("D1")) & "\"

        MyBook = CStr(.Range("C16")) & ".xls"

    End With

    '=====================

    Set sh = ActiveWorkbook.Worksheets(MySheet_Post)

    '=====================

    MyFilOpen = MyPath & MyBook

    '=====================

    If Dir(MyFilOpen, vbDirectory) = vbNullString Then

        MsgBox "رابط غير موجود"

    Else

        Workbooks.Open Filename:=MyFilOpen

        Sheets(1).Columns("A:A").Copy sh.Range("A1")

        Workbooks(MyBook).Close False

        MsgBox "تم نسخ البيانات الى الورقة : " & vbCr & MySheet_Post

        sh.Activate

    End If

    '=====================

Err_mydate:

    If Err Then MsgBox "Err.Number:" & vbCr & Err.Number

    '=====================

    Application.ScreenUpdating = True

    Set sh = Nothing

End Sub

شاهد المرفق اكسل 2003

tahar1.rar

[ريان أحمد]

السلام عليكم شكرا على المرور السريع والمتألق

بالنسبة للمطلوب الأول فهو المطلوب ووبلا شك

أستاذي خبور الملف الذي بإسم QTT01_04.11 هو من نوع dbfمصمم في لغة برمجة dbase وليس bdf كما دكرت سابقا فالمعذرة

أما إذا كانت هذا النوع كذلك لا يستطيع التعامل معه الكود

فعندي حل الرجاء مساعدتي فيه بالكود والشرح في المرفق

الملف tt الذي في المرفق هو ملف يحتوي على الملفات التي بنوع dbf

يقوم الماكرو بفتح الملفات في tt وحفضها بإسم تبعا للخلية c16

مع الحفاض على الملف الأصلي

ثم أرجع للخلية c16 لأجد فيها ملف بصيعة xls وينجح كود تبعك

Archive.rar

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

السلام عليكم

اما إذا كانت هذا النوع كذلك لا يستطيع التعامل معه الكود

لقد تم التعامل مع الملف

والحمد لله

تم التعديل على الكود كما يلي:

Option Explicit

Option Compare Text

'  اسم الورقة التي سيتم لصق البيانات فيها

Const MySheet_Post As String = "post"

'


Sub kh_copy_mydate()

    Dim sh As Worksheet

    Dim MyFilOpen As String, MyPath As String, MyBook As String

    '=====================

    On Error GoTo Err_mydate

    '=====================

    Set sh = ActiveWorkbook.Worksheets(ActiveSheet.Name)

    Application.ScreenUpdating = False

    '=====================

    With sh

        MyPath = CStr(.Range("C1")) & ":\" & CStr(.Range("D1")) & "\"

        MyBook = CStr(.Range("C16")) & File_Type(MyPath & .Range("C16"))

    End With

    '=====================

    Set sh = ActiveWorkbook.Worksheets(MySheet_Post)

    '=====================

    MyFilOpen = MyPath & MyBook

    '=====================

    If Dir(MyFilOpen, vbDirectory) = vbNullString Then

        MsgBox "رابط غير موجود"

    Else

        Workbooks.Open Filename:=MyFilOpen

        Sheets(1).Columns("A:A").Copy sh.Range("A1")

        Workbooks(MyBook).Close False

        MsgBox "تم نسخ البيانات الى الورقة : " & vbCr & MySheet_Post

        sh.Activate

    End If

    '=====================

Err_mydate:

    If Err Then MsgBox "Err.Number:" & vbCr & Err.Number

    '=====================

    Application.ScreenUpdating = True

    Set sh = Nothing

End Sub


------------------------------------

Function File_Type(MyTest As String) As String

Dim MyType As String

MyType = ".xls"

If Not Dir(MyTest & MyType, vbDirectory) = vbNullString Then

    File_Type = MyType

End If

End Function

شاهد المرفق

tahar2.rar

[ريان أحمد]

السلام عليكم

نعم كالعادة وبلا شك متميز ومتألق نعم هو المطلوب بعينه

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

لكن بقي طلب صغيييييييييييييييييييييييييييييييييييييييييييييييير هو أن أجعل كل هذا في فورم أي مكان إدخال إسم الملف ا والدرايف وإسم الملف الذي في الخلية c16 وهذه الفورم يتم إستذعاؤها بزر كذلك

ماهي الملفات التي يتعامل معها الكود بخلاف xls *dbf

[ريان أحمد]

تم تعديل أبريل 17, 2011 بواسطه tahar1983

[عبدالله المجرب]

لكن بقي طلب صغيييييييييييييييييييييييييييييييييييييييييييييييير هو أن أجعل كل هذا في فورم أي مكان إدخال إسم الملف ا والدرايف وإسم الملف الذي في الخلية c16 وهذه الفورم يتم إستذعاؤها بزر كذلك

ماهي الملفات التي يتعامل معها الكود بخلاف xls *dbf

اخي طاهر

وبعد اذن استاذنا خبور خير حفظه الله

تفضل المرفق

اخوك ابو احمد

tahar3.rar

[محب إكسل]

شكرا

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

[محب إكسل]

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

[ريان أحمد]

السلام عليكم

أستاذي ولد مجرب أستاذي خبور إلى كل أساتذة المنتدلى

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

شكرا عل المرور الطيب

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