اريد كود vba لحفظ ملف داخل مجلد يتم انشاءه وفق شرطين

[الحضرمي2017]

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

كيف حالكم اخواني الاحبه 

كما هو موضح بالعنوان لو تكرمتم اريد كود بال vba لتصدير النطاق المحدد باللون الى ملف .xlsm بشرط أن يكون في فولدر يتم انشاءه اذا لم يكن موجود واذا كان موجود اي الفولدر يتم وضع الملف بداخله ويكون اسم الملف وفق بيانات الخلية a1 و اسم الفولدر وفق بيانات الخليه b1

وقد ارفقت ملف يوضح المطلوب وجزاكم الله خير الجزاء 

ملف العمل.xlsx

[أحمد يوسف]

وعليكم السلام -وما هو الغرض والهدف من هذا فيمكنك اخذ الملف الذى تريده وعمل كوبى له ووضعه فى الفولدر المراد الحفظ فيه

فما تريد وتطلب ليس بالسهل او الهين

 

[الحضرمي2017]

الغرض أخي الحبيب اني اعمل في مدرسة وعلي طبعة نتائج الصفوف وتعرف انت نطاقات بيانات كل فصل فهي كثيرة لذا فكرت بوضع زر يقوم بالعمل لكني لم افلح 

بحيث اني لما انتهي من كل فصل اضغط على ازر فيصدر لي الملف الى مجلد يتم انشائه واذا كان موجود يحفظ الملف بداخله

ادري ان العمل ليس بسهل ولذا اجد نفسي عاجز عن اتقانه فقلت لعل من في المنتدى من يفيدني وآسف اخي الحبيب 

تم تعديل يناير 18, 2019 بواسطه الحضرمي2017

[الحضرمي2017]

لقيت هذا الكود لا نشاء مجلد

Sub MakeMyFolder()
انشاء المجلد '
    Dim fdObj As Object
    Application.ScreenUpdating = False
    Set fdObj = CreateObject("Scripting.FileSystemObject")
    If fdObj.FolderExists("C:\Users\ALHDRAMI\Desktop\as") Then
        MsgBox "Found it.", vbInformation, "Kutools for Excel"
    Else
        fdObj.CreateFolder ("C:\Users\ALHDRAMI\Desktop\as")
        MsgBox "It has been created.", vbInformation, "Kutools for Excel"
    End If
    Application.ScreenUpdating = True
End Sub

وهذا كود ثاني لانشاء مجلد وحفظ شيت معين بداخله

 

Sub Mfolder_Export_SheetPDF()
'انشاء ملف
Dim Name As String, Path As String
Path = "c:\Snow Eagle" & Format(Now, "dd-mm-yyyy hh.mm.ss")
MkDir Path
Name = Sheets("Sheet3").Name
Sheets("Sheet3").ExportAsFixedFormat xlTypePDF, Path & "\" & Name
End Sub

مشكلة أني لم استطع توظيف اي منهن في الفكرة التي في ذهني فهل احد يتفضل بالمساعدة وجزاكم الله خير الجزاء

[محمد يوسف]

السلام عليكم  الحضرمي2017

هنا  https://www.officena.net/ib/index.php?showtopic=36524

او

هناhttp://www.officena.net/ib/index.php?showtopic=29935

 

او

 

https://www.officena.net/ib/applications/core/interface/file/attachment.php?id=50849

[الحضرمي2017]

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

Sub Macro1()
Dim strFilename, strDirname, strPathname, strDefpath As String
 On Error Resume Next ' If directory exist goto next line
strDirname = Range("D81").Value ' New directory name

strFilename = Range("D8").Value 'New file name
strDefpath = Application.ActiveWorkbook.Path 'Default path name
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string

ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

 

تم تعديل يناير 18, 2019 بواسطه الحضرمي2017

[الحضرمي2017]

فيه اشكالية بسيطة ارجو من احد الاخوة أن يفيدني بها وهي 

أني استبدال 

ActiveWorkbook.SaveAs

ب 

ActiveWorkbook.SavecopyAs

حتى يتم حفظ الملف باسم مختلف في كل مرة 

لأن المشكلة انني لما اعمل حفظ في المرة الأولى واسوي حفظ للمرة الثانية ينشئ المجلد داخل الملجد الاول وهكذ مجلد داخل مجلد 

[طارق نادر]

16 ساعات مضت, الحضرمي2017 said:

فيه اشكالية بسيطة ارجو من احد الاخوة أن يفيدني بها وهي 

أني استبدال 

ActiveWorkbook.SaveAs

ب 

ActiveWorkbook.SavecopyAs

حتى يتم حفظ الملف باسم مختلف في كل مرة 

لأن المشكلة انني لما اعمل حفظ في المرة الأولى واسوي حفظ للمرة الثانية ينشئ المجلد داخل الملجد الاول وهكذ مجلد داخل مجلد 

 تفضل اخي الكريم

الاسم الي بالون الاخضر غيره حسب الاسم الذي تريد حفظ الملف به... 

ActiveWorkbook.SaveAs Filename:="C:\Users\tareq\Documents\Book1.xlsx", _
        FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

[الحضرمي2017]

جزاك الله خير أخي الحبيب طارق نادر 

تم حل الاشكالية ووالله مدري هل طريقة صحيحة أم لا المهم أني حذفت بعض الكلمات وضبط معي الأمر ولا أدري كيف 

Sub Macro1()
Dim strFilename, strDirname, strPathname, strDefpath As String
 On Error Resume Next ' If directory exist goto next line
strDirname = Range("a1").Value ' New directory name

strFilename = Range("a2").Value 'New file name
strDefpath = Application.ActiveWorkbook.Path 'Default path name
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string

ActiveWorkbook.SaveCopyAs Filename:=strPathname & ".xlsm"

End Sub

الكود بعد التعديل عليه صار يسوي لي ملجد اسمه من البيانات الموجودة في A1 

ويضع ملف بداخلة بصيغة xlsm اسمه وفق البيانات الموجودة في A2

وهو ما اردته بالضبط فالله الحمد والمنة

[الحضرمي2017]

12 دقائق مضت, الحضرمي2017 said:

جزاك الله خير أخي الحبيب طارق نادر 

تم حل الاشكالية ووالله مدري هل طريقة صحيحة أم لا المهم أني حذفت بعض الكلمات وضبط معي الأمر ولا أدري كيف 

Sub Macro1()
Dim strFilename, strDirname, strPathname, strDefpath As String
 On Error Resume Next ' If directory exist goto next line
strDirname = Range("a1").Value ' New directory name

strFilename = Range("a2").Value 'New file name
strDefpath = Application.ActiveWorkbook.Path 'Default path name
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string

ActiveWorkbook.SaveCopyAs Filename:=strPathname & ".xlsm"

End Sub

الكود بعد التعديل عليه صار يسوي لي ملجد اسمه من البيانات الموجودة في A1 

ويضع ملف بداخلة بصيغة xlsm اسمه وفق البيانات الموجودة في A2

وهو ما اردته بالضبط فالله الحمد والمنة

الاشكالية الوحيدة الان والتي آمل أن أجد من يسعفني في حلها الكود اللي في المشاركة سليم ويعمل تمام التمام الاشكالية في الاتي : 

1- ان الملف الناتج يكون في الغالب بجانب الملف اللي اعمل به وهذا لا اريدة اريدة دائما وابدا ينشأ لي المجلد على سطح المكتب

2- ليس بتلك الاهمية وهو هل بامكاني أن أحدد النطاق الذي سيتم حفظه في الملف الجديد اذا أمكن

[toytotan]

جماعة الخير السلام عليكم

لو حبيت اجعل الملف الذى تم انشاءة بصيغة pdf 

ولكم جزيل الشكر

تم تعديل أبريل 22, 2023 بواسطه toytotan

[بلانك]

استبدل

"ActiveWorkbook.SaveCopyAs Filename:=strPathname & ".xlsm

ب

 

"ActiveWorkbook.SaveCopyAs Filename:=strPathname "& ".pdf