تصدير صفحات الى مصنف جديد عن طريق الفورم

[Abaas]

السلام عليكم ... اذا امكن عمل فورم يقوم بإظهار جميع الشيتات في المصنف ويقوم بتصدير الشيتات المحددة الى مصنف مجاور للمصنف الاصلي .. ويتم تصدير كل صفحة بالقيم فقط .. وتحويل كافة المعادلات الى قيم لكي تبقى النتائج كما هي اثتاء تصدير الشيتات .. مع شكري وتقديري

[محمد هشام.]

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

 

المفروض أخي على الأقل تصميم اليوزرفورم الخاص بك

  مع توضيح هل يتم نسخ الشيتات الى مصنف معين مفتوح أو موجود مسبقا في نفس مسار المصنف الأصلي أو  يتم إنشاءه 

 

 

[Abaas]

شكرا للاخ محمد هشام ...

يتم التصدير لملف جديد يتم انشائه بنفس مسار المصنف الاصلي ..ويكون ظهور صفحات محددة للتصدير وليس الكل الفورم او تصدير الكل كما موضح بالفورم.. جزيل شكري على الرد

تصدير صفحات.xlsm

تم تعديل الجمعة at 02:08 بواسطه Abaas

[محمد هشام.]

تفضل جرب هدا

Dim Sh As Boolean
' إسم المصنف الجديد
Private Const WBname As String = "المجمع.xlsx"

Private Sub UserForm_Initialize()
    Dim WS As Worksheet, CrWS As Variant, i As Integer
    ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها
    CrWS = Array("Sheet1", "Sheet2", "Sheet3")
    For Each WS In ThisWorkbook.Worksheets
        For i = LBound(CrWS) To UBound(CrWS)
            If WS.name = CrWS(i) Then
                ListBox1.AddItem WS.name
                Exit For
            End If
        Next i
    Next WS
End Sub
Private Sub CommandButton1_Click()
    Dim i As Integer, ShName As String, newWb As Workbook, sPath As String
    Dim tmps As Integer, shArr As String, sCount As Integer
    
    tmps = 0
    For i = 0 To Me.ListBox1.ListCount - 1
        If Me.ListBox1.Selected(i) Then tmps = tmps + 1
    Next i

    If tmps = 0 And Not CheckBox1.Value Then
        MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "إنتباه"
        Exit Sub
    End If

    Sh = True
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        .DisplayAlerts = False
        .CopyObjectsWithCells = False
        .Calculation = xlCalculationManual
    End With

    If Sh Then
        Set newWb = CreateWb()
        sPath = ThisWorkbook.path & "\" & WBname
        SaveNewWorkbook newWb, sPath

        sCount = 0
        If CheckBox1.Value Then
            For i = 0 To Me.ListBox1.ListCount - 1
                ShName = Me.ListBox1.List(i)
                CopySheetToNewWorkbook ThisWorkbook.Sheets(ShName), newWb
                shArr = shArr & ShName & vbNewLine
                sCount = sCount + 1
            Next i
        Else
            For i = 0 To Me.ListBox1.ListCount - 1
                If Me.ListBox1.Selected(i) Then
                    ShName = Me.ListBox1.List(i)
                    CopySheetToNewWorkbook ThisWorkbook.Sheets(ShName), newWb
                    shArr = shArr & ShName & vbNewLine
                    sCount = sCount + 1
                End If
            Next i
        End If

        WSDelete newWb
        newWb.Save
        newWb.Close SaveChanges:=True

        With Application
            .ScreenUpdating = True
            .EnableEvents = True
            .CopyObjectsWithCells = True
            .DisplayAlerts = True
            .Calculation = xlCalculationAutomatic
        End With

        Unload Me

        MsgBox IIf(sCount = 1, "تم حفظ الورقة بنجاح", "تم حفظ الأوراق بنجاح") & vbNewLine & vbNewLine & shArr, vbInformation
     End If
End Sub
Private Function CreateWb() As Workbook
    Dim newWb As Workbook
    Set newWb = Workbooks.Add(xlWBATWorksheet)
    newWb.Sheets(1).name = "New"
    Set CreateWb = newWb
End Function

Private Sub SaveNewWorkbook(ByVal newWb As Workbook, ByVal filePath As String)
    On Error Resume Next
    newWb.SaveAs fileName:=filePath, FileFormat:=xlOpenXMLWorkbook
    On Error GoTo 0
End Sub

Private Sub CopySheetToNewWorkbook(ByVal sourceSheet As Worksheet, ByVal targetWorkbook As Workbook)
    sourceSheet.Copy After:=targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
    Dim WS As Worksheet
    Set WS = targetWorkbook.Sheets(targetWorkbook.Sheets.Count)
    WS.UsedRange.Value = WS.UsedRange.Value
    Application.CutCopyMode = False
End Sub
Private Sub WSDelete(ByVal newWb As Workbook)
    On Error Resume Next
    newWb.Sheets("New").Delete
    On Error GoTo 0
End Sub

 

تصدير صفحات v2.xlsm

[Abaas]

الاخ محمد هشام جزاكم الله خيرا ...ممكن التحكم باسم المصنف الجديد بحيث يكون اسمه مرتبط بخلية داخل احدى صفحات الملف الاصلي ..  وكذلك تكون متفضلا لو تم اضافة كود ايضا يقوم بتحويل الصفحات الى pdf لكل الصفحات او للصفحات معينة .. تحياتي لك مرة اخرى .. واسف على الاطالة

تم تعديل الجمعة at 09:21 بواسطه Abaas

[محمد هشام.]

21 ساعات مضت, Abaas said:

.ممكن التحكم باسم المصنف الجديد بحيث يكون اسمه مرتبط بخلية داخل احدى صفحات الملف الاصلي

Dim Sh As Boolean
Public Property Get f() As Worksheet 
    Set f = Sheets("Sheet1") <=========   إسم ورقة العمل المرغوب جلب إسم المصنف الجديد منها
End Property
Private Sub UserForm_Initialize()
    Dim WS As Worksheet, CrWS As Variant, i As Integer
    ' قم بتعديل أسماء أوراق العمل المرغوب إظهارها
    CrWS = Array("Sheet1", "Sheet2", "Sheet3")
    For Each WS In ThisWorkbook.Worksheets
        For i = LBound(CrWS) To UBound(CrWS)
            If WS.name = CrWS(i) Then
                ListBox1.AddItem WS.name
                Exit For
            End If
        Next i
    Next WS
     HideBar Me
End Sub
Private Sub CommandButton1_Click()
    Dim i As Integer, ShName As String, newWb As Workbook, sPath As String
    Dim tmps As Integer, shArr As String, sCount As Integer, WBname As String
    WBname = f.[R2].Value  <=======  قم بتعديل عنوان خلية الإسم بما يناسبك
    If WBname = "" Then: MsgBox "الرجاء إدخال إسم المصنف ", vbExclamation, "إنتباه": Exit Sub
    'Code........
         ..............
      End Sub                            

 

21 ساعات مضت, Abaas said:

كود ايضا يقوم بتحويل الصفحات الى pdf لكل الصفحات او للصفحات معينة

 

Private Sub CommandButton2_Click()
    On Error GoTo SupApp
    Dim arr As New Collection, TempWb As Workbook, WS As Worksheet
    Dim i As Integer, sMsg As Integer, tbl As Boolean
    Dim WBname As String, sPath As String, shArr As String

    WBname = Trim(f.Range("R2").Value)
    If WBname = "" Then MsgBox "الرجاء إدخال اسم المصنف", vbExclamation, "تنبيه": Exit Sub

    tbl = Me.CheckBox1.Value
    For i = 0 To Me.ListBox1.ListCount - 1
        If tbl Or Me.ListBox1.Selected(i) Then
            arr.Add Me.ListBox1.List(i)
            shArr = shArr & Me.ListBox1.List(i) & "- "
            sMsg = sMsg + 1
        End If
    Next
    If sMsg = 0 Then MsgBox "الرجاء تحديد ورقة عمل واحدة على الأقل", vbExclamation, "تنبيه": Exit Sub

    If Len(shArr) > 0 Then
        shArr = Left(shArr, Len(shArr) - 2)
    End If

    If MsgBox("هل أنت متأكد أنك تريد حفظ الأوراق التالية؟" & _
    vbNewLine & vbNewLine & shArr, vbYesNo + vbQuestion, "PDF" & " تأكيد الحفظ") = vbNo Then Exit Sub

    With Application
        .ScreenUpdating = False: .EnableEvents = False: .DisplayAlerts = False: .Calculation = xlCalculationManual
    End With

    Set TempWb = Workbooks.Add(xlWBATWorksheet)
    For i = 1 To arr.Count
        ThisWorkbook.Sheets(arr(i)).Copy After:=TempWb.Sheets(TempWb.Sheets.Count)
    Next

    sPath = ThisWorkbook.path & "\" & WBname & ".pdf"
    If Dir(sPath) <> "" Then Kill sPath
    TempWb.ExportAsFixedFormat Type:=xlTypePDF, fileName:=sPath, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
    TempWb.Close False

    MsgBox "تم حفظ الملفات بنجاح", vbInformation, "PDF حفظ"
    Unload Me

CleanUp:
    With Application
        .ScreenUpdating = True: .EnableEvents = True: .DisplayAlerts = True: .Calculation = xlCalculationAutomatic
    End With
    Exit Sub

SupApp:
    On Error Resume Next: If Not TempWb Is Nothing Then TempWb.Close False
    Resume CleanUp
End Sub

 

 

تصدير صفحات v3.xlsm

تم تعديل السبت at 05:54 بواسطه محمد هشام.

[Abaas]

كل الشكر للاخ محمد هشام على جهوده ... بارك الله فيك وبجميع الاخوة في هذا الصرح العلمي الكبير