اذهب الي المحتوي
أوفيسنا

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


الردود الموصى بها

السلام عليكم

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

عندما إخترت الملف 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

رابط هذا التعليق
شارك

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

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

اخي طاهر

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

تفضل المرفق

اخوك ابو احمد

tahar3.rar

رابط هذا التعليق
شارك

السلام عليكم

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

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

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

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

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information