تغيير اسم ورقة عن طريق الكود

[Al Nada]

بسم الله والصلاة والسلام على رسول اللهالسلام عليكم ورحمة الله وبركاتهلدي مشكله صغيرة في هذا الملف وهير عند التصدير الى ملف جديد اريد ان تصبح اسم الورقة في هذا الملف = قيم الخلية [F9] في الملف الاصلي للملاحضة : لقد وضعت مشاركة من فترة وجيزة ولكن لم يساعدني احد في حلها وهي " ترحيل ورقة خارج المصنف الاساسي " على العموم توصلت الى حلها بفضل الله وبفضل هذا المنتدى ولكن ما اريده هو عن التصدير الى الملف الجديد ان يتغير اسم الورق ( في الملف الجديد ) ، الى الرقم النوجود في الخلية [F9] الموجودة في صفحة الادخال والتي تتغير تلقائيا بمجرد الضفط على زر ترحيل اتمنى المساعدة ولكم لاجر والثواب عند الله تعالى " ان الله لا يضيع اجر من احسن عملا " صدق الله العظيمالملف بالمرفقات مع فائق الاحترام والتقدير

حوالات_اصدار جديد.zip

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

السلام عليكم

Private Sub CommandButton1_Click()

Dim NUEVO As Workbook

Dim MyPath As String, MyName As String

Dim i As Integer, X As Integer, j As Integer, final As Integer

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

MyName = jaboor.Cells(9, "F") & ".xls"

MyPath = ActiveWorkbook.Path & "\" & MyName

Set NUEVO = Workbooks.Add(-4167)

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

For i = 38 To 1000

    If jaboor.Cells(i, 1) = "" Then

        final = i - 1

        Exit For

    End If

Next


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


For j = 13 To final

    For X = 1 To 12

        With NUEVO.Worksheets(1)

            .Cells(j - 12, X) = jaboor.Cells(j, X)

        End With

    Next X

Next j

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

UserForm1.Hide

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

If Not Dir(MyPath, vbDirectory) = vbNullString Then

    MsgBox "اسم الملف مكرر لن يتم حفظه " & Chr(10) & "قم بحفظه بنفسك", vbCritical + vbMsgBoxRight, "تنبيه"

Else

    NUEVO.SaveAs MyPath

End If

End Sub

تفضل المرفق

حوالات_اصدار جديد.rar

[قصي]

شكرا . شكرا. شكرا . شكرا

[Al Nada]

السلام عليكم ورحمة الله وبركاتهشكراً جزيلاً اخي خبور خير وجزاك الله عنا خير الجزاء

[Al Nada]

اخي الكريم خبور خير جزاك الله خيرًاًولكن هناك مشكلة وهي اسم الورقة لم يتم تغيير اسمها احب ان اذكرك بالمطلوب هو تغيير اسم الورقة الى الرقم الموجود في الخلية [F9] بالاضافة الى اسم الملف اي اسم الملف واسم الورقة يحملان نفس الاسم وهو الرقم الموجود في الخلية [F9] ولك الشكر مع فائق الاحترام والتقدير اخوك جابر

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

السلام عليكم

اخي الكريم خبور خير جزاك الله خيرًاًولكن هناك مشكلة وهي اسم الورقة لم يتم تغيير اسمها احب ان اذكرك بالمطلوب هو تغيير اسم الورقة الى الرقم الموجود في الخلية [F9] بالاضافة الى اسم الملف اي اسم الملف واسم الورقة يحملان نفس الاسم وهو الرقم الموجود في الخلية [F9] ولك الشكر مع فائق الاحترام والتقدير اخوك جابر

غير الكود بتاع الفورم الى التالي:

Private Sub CommandButton1_Click()

Dim NUEVO As Workbook

Dim MyPath As String, MyName As String

Dim i As Integer, X As Integer, j As Integer, final As Integer

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

MyName = jaboor.Cells(9, "F")

MyPath = ActiveWorkbook.Path & "\" & MyName & ".xls"

Set NUEVO = Workbooks.Add(-4167)

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

For i = 38 To 1000

    If jaboor.Cells(i, 1) = "" Then

        final = i - 1

        Exit For

    End If

Next


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

With NUEVO.Worksheets(1)

    .Name = MyName

    For j = 13 To final

        For X = 1 To 12

            .Cells(j - 12, X) = jaboor.Cells(j, X)

        Next X

    Next j

End With

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

UserForm1.Hide

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

If Not Dir(MyPath, vbDirectory) = vbNullString Then

    MsgBox "اسم الملف مكرر لن يتم حفظه " & Chr(10) & "قم بحفظه بنفسك", vbCritical + vbMsgBoxRight, "تنبيه"

Else

    NUEVO.SaveAs MyPath

End If

End Sub

[Al Nada]

السلام عليكم ورحمة الله وبركاته شكرا جزلاً اخي خبور على الاهتمام اتعبتك معاي لكن هناك مشكلة هي ان الملف المصدر يتم تخزينه على نفس المسار الموجود فيه الملف الاساسي ActiveWorkbook.Path هل استطيع تحديد مسار معين غير مرتبط بموقع الملف الاساسي بارك الله فيك وبجهودك العظيمة

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

السلام عليكم

غير الكود بالتالي:

Private Sub CommandButton1_Click()

Dim NUEVO As Workbook

Dim MyName_Book, FileSaveName

Dim MyName_Sheet As String

Dim i As Integer, X As Integer, j As Integer, final As Integer

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

MyName_Sheet = jaboor.Cells(9, "F")

MyName_Book = ActiveWorkbook.Path & "\" & MyName_Sheet & ".xls"

Set NUEVO = Workbooks.Add(-4167)

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

For i = 38 To 1000

If jaboor.Cells(i, 1) = "" Then

final = i - 1

Exit For

End If

Next

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

With NUEVO.Worksheets(1)

.Name = MyName_Sheet

For j = 13 To final

For X = 1 To 12

.Cells(j - 12, X) = jaboor.Cells(j, X)

Next X

Next j

End With

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

UserForm1.Hide

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

FileSaveName = Application.GetSaveAsFilename(MyName_Book, "xls Files (*.xls), *.xls")

1:

If FileSaveName = False Then Exit Sub

If Not Dir(FileSaveName, vbDirectory) = vbNullString Then

MsgBox "اسم الملف مكرر " & Chr(10) & "قم بحفظه باسم آخر", vbCritical + vbMsgBoxRight, "تنبيه"

FileSaveName = Application.GetSaveAsFilename(, "xls Files (*.xls), *.xls")

GoTo 1

Else

NUEVO.SaveAs FileSaveName

MsgBox "Save as " & FileSaveName

End If

End Sub

[Al Nada]

شكرا جزيلا استاذ خبور

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

[Al Nada]

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

اخواني الاعزاء

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

متأسف لاطالة الموضوع ولكن لعل في ذلك خير للجميع

اريد ان اضع زر عمله شبيه بعمل زر كشف حوالات ولكن هنا ان يتم الترحيل الى ملف وورد وهنا يتم نسخ بيانات صفحة الادخال (نطاق ناحية الطباعة) ،

الى ملف وورد جديد ويتم حفظة في مسار (يحدد عن طريق الكود ) ...

اتمنى ان اكون وفقت بايصال المطلوب ولكم الشكر ..

مع فائق الاحترام والتقدير

تم تعديل أبريل 26, 2010 بواسطه Al Nada

[Al Nada]

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

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

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

والله الموفق

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

مع فائق الاحترام والتقدير