تصدير عده شيتات في ملف الي اكثر من ملف

وائل الاسيوطي · أكتوبر 22, 2015

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

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

والتاريخ الموجود في الخليه A1 من الصفحه الاولي

ملحوظه بعد الفصل لابد ان تكون الصفحات غير مرتبطه بالملف الاصلي

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

Sales 7 UCP Stk 14-4-2015.rar

**مختار حسين محمود** · أكتوبر 23, 2015

السلام عليكم أخى الأسيوطى

جرب الملف التالى فيه نحفظ الورقة الاولى والثانية + ورقة من الاوراق التالية لهما فى ملف مستقل باسم حسب الخلية C1 فى هذه الورقه

يتم تجميع الملفات الناتجة داخل مجلد يتم انشاؤه حسب اسم الملف والتاريخ الموجود في الخليه A1 من الصفحه الاولي

لا تنسونا من صالح الدعاء ولو بظهر الغيب تحياتى

Save Sheets As Books by mokhtar.rar

وائل الاسيوطي · أكتوبر 23, 2015

السلام عليكم أخى الأسيوطى

جرب الملف التالى فيه نحفظ الورقة الاولى والثانية + ورقة من الاوراق التالية لهما فى ملف مستقل باسم حسب الخلية C1 فى هذه الورقه

يتم تجميع الملفات الناتجة داخل مجلد يتم انشاؤه حسب اسم الملف والتاريخ الموجود في الخليه A1 من الصفحه الاولي

لا تنسونا من صالح الدعاء ولو بظهر الغيب تحياتى

Save Sheets As Books by mokhtar.rar

السلام عليكم من اخيك الاسيوطي ياخي مختار الاسيوطي التي افخر انها تضم عباقره مثلك اخي الحبيب

عمل رائع يضم لقائمه اعمالك الرائعه

.لي طلب اخير ان الصفحه الاولي صفحه sales لاتخرج مع باقي الملفات

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

**مختار حسين محمود** · أكتوبر 23, 2015

وعليكم السلام أستاذ وائل

استبدل السطر التالى فى كود المرفق

ThisWorkbook.Sheets(Array("SAles", "Stk")).Copy Before:=NB.Sheets(1)

بالسطر التالى :

  ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1)

تحياتى

ياسر خليل أبو البراء · أكتوبر 23, 2015

أخي وحبيبي مختار

بارك الله فيك ملف رائع وجميل

ولكن لاحظ ان المخرجات مرتبطة بالملف الأصلي .. روح على الشيت التالت في أي مصنتف من المخرجات

تقبل تحياتي

وائل الاسيوطي · أكتوبر 23, 2015

وعليكم السلام أستاذ وائل

استبدل السطر التالى فى كود المرفق
ThisWorkbook.Sheets(Array("SAles", "Stk")).Copy Before:=NB.Sheets(1)
بالسطر التالى :
  ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1)
                     
     
تحياتى

تمام تم حل المشكله ولكن اصبحت الان مشكله الارتباط بالملف الاصلي التي ذكرها اخي ياسر

تم تعديل أكتوبر 23, 2015 بواسطه وائل الاسيوطي

**مختار حسين محمود** · أكتوبر 23, 2015

لم ألتفت الى المعادلات أشكرك أخى ياسر على دقة المتابعة تم تعديل نوع لصق المنسوخ فى الكود

Option Explicit

Sub SaveShtsAsBook()
      
      Dim MyFilePath As String, SheetName1 As String, SheetName2 As String, sh As Worksheet, NB As Workbook
      
      MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & Format([a1], "dd-mm-yyyy")
                   
      With Application
            .ScreenUpdating = False
          
            .DisplayAlerts = False
             On Error Resume Next
             MkDir MyFilePath
            
             For Each sh In Sheets(Array("cairo 1", "cairo2", "u2", "Alex ", "Delta 3", "Delta 2", "Delta 1", "u1"))
                  sh.Activate
                  SheetName1 = ActiveSheet.Name
                  SheetName2 = ActiveSheet.Name & "" & [c1]
                  Cells.Copy
                  
                  Set NB = Workbooks.Add(xlWBATWorksheet)
                  
                  With NB
                        With .ActiveSheet
                             .Cells.PasteSpecial Paste:=xlPasteValues
                             .Name = SheetName1
                              [a1].Activate
                        End With
                        ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1)
                        
                        .SaveAs Filename:=MyFilePath & "\" & SheetName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                      
                        .Close SaveChanges:=True
                        
                  End With
                  
              .CutCopyMode = False
              Set NB = Nothing
              Next sh
              Sheets("SAles").Activate
             .ScreenUpdating = True
             .DisplayAlerts = True
      End With
      
End Sub

ياسر خليل أبو البراء · أكتوبر 23, 2015

بارك الله فيك أخي الحبيب مختار

فقط أضف سطر آخر للحفاظ على تنسيقات ورقة العمل قبل لصق القيم

                    .Cells.PasteSpecial Paste:=xlAll
                    .Cells.PasteSpecial Paste:=xlPasteValues

وائل الاسيوطي · أكتوبر 23, 2015

بارك الله فيك أخي الحبيب مختار

فقط أضف سطر آخر للحفاظ على تنسيقات ورقة العمل قبل لصق القيم
                    .Cells.PasteSpecial Paste:=xlAll
                    .Cells.PasteSpecial Paste:=xlPasteValues

اضيفه فين بالضبط اخي ياسر

ياسر خليل أبو البراء · أكتوبر 23, 2015

أخي الكريم واائل يا مكسل تدور جوا الكود على السطر اللي عليه العين

إليك الكود بالكامل (بس مختار كدا هيزعل إنني اتدخلت في كوده ..عموماً أنا عارف إنه قلبه طيب وهيسامح)

Sub SaveShtsAsBook()
    Dim MyFilePath As String, SheetName1 As String, SheetName2 As String, sh As Worksheet, NB As Workbook
    MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & Format([a1], "dd-mm-yyyy")
   
    With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        On Error Resume Next
        MkDir MyFilePath
        
        For Each sh In Sheets(Array("cairo 1", "cairo2", "u2", "Alex ", "Delta 3", "Delta 2", "Delta 1", "u1"))
            sh.Activate
            SheetName1 = ActiveSheet.Name
            SheetName2 = ActiveSheet.Name & "" & [c1]
            Cells.Copy
            
            Set NB = Workbooks.Add(xlWBATWorksheet)
            
            With NB
                With .ActiveSheet
                    .Cells.PasteSpecial Paste:=xlAll
                    .Cells.PasteSpecial Paste:=xlPasteValues
                    .Name = SheetName1
                    [a1].Activate
                End With
                ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1)
                .SaveAs Filename:=MyFilePath & "\" & SheetName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                .Close SaveChanges:=True
            End With
            
            .CutCopyMode = False
            Set NB = Nothing
        Next sh
        Sheets("SAles").Activate
        .ScreenUpdating = True
        .DisplayAlerts = True
    End With
End Sub

**مختار حسين محمود** · أكتوبر 23, 2015

كده

Option Explicit

Sub SaveShtsAsBook()
      
      Dim MyFilePath As String, SheetName1 As String, SheetName2 As String, sh As Worksheet, NB As Workbook
      
      MyFilePath = ActiveWorkbook.Path & "\" & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & Format([a1], "dd-mm-yyyy")
                   
      With Application
            .ScreenUpdating = False
          
            .DisplayAlerts = False
             On Error Resume Next
             MkDir MyFilePath
            
             For Each sh In Sheets(Array("cairo 1", "cairo2", "u2", "Alex ", "Delta 3", "Delta 2", "Delta 1", "u1"))
                  sh.Activate
                  SheetName1 = ActiveSheet.Name
                  SheetName2 = ActiveSheet.Name & "" & [c1]
                  Cells.Copy
                  
                  Set NB = Workbooks.Add(xlWBATWorksheet)
                  
                  With NB
                        With .ActiveSheet
                          .Cells.PasteSpecial Paste:=xlAll
                          .Cells.PasteSpecial Paste:=xlPasteValues
                          .Name = SheetName1
                          [a1].Activate
                        End With
                        ThisWorkbook.Sheets("Stk").Copy Before:=NB.Sheets(1)
                        
                        .SaveAs Filename:=MyFilePath & "\" & SheetName2 & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                      
                        .Close SaveChanges:=True
                        
                  End With
                  
              .CutCopyMode = False
              Set NB = Nothing
              Next sh
              Sheets("SAles").Activate
             .ScreenUpdating = True
             .DisplayAlerts = True
      End With
      
End Sub

وائل الاسيوطي · أكتوبر 23, 2015

تم بحمد الله وفضله

ثنائيه رائعه من العمل والعلم اخي ياسر واخي مختار

زادكم الله من علمه وفضله

**مختار حسين محمود** · أكتوبر 23, 2015

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

بارك الله فيك أخى وائل ونفع بك تحياتى

وائل الاسيوطي · أكتوبر 23, 2015

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

تقبلوا تحياتي

تسجيل الدخول

تصدير عده شيتات في ملف الي اكثر من ملف

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

وائل الاسيوطي

مختار حسين محمود

وائل الاسيوطي

مختار حسين محمود

ياسر خليل أبو البراء

وائل الاسيوطي

مختار حسين محمود

ياسر خليل أبو البراء

وائل الاسيوطي

ياسر خليل أبو البراء

مختار حسين محمود

وائل الاسيوطي

مختار حسين محمود

وائل الاسيوطي

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information