مشكله فى حفظ شيت من ملف به عدد من الشيتات

[hesham monzer1]

sub Finish()
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String
Application.ScreenUpdating = False
Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    xWs.Copy
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
        Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.HasVBProject Then

                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56:
                FileExtStr = ".xls": FileFormatNum = 56
            Case Else:
                FileExtStr = ".xlsb": FileFormatNum = 50
        End Select
    End If
    xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
    Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
    Application.ActiveWorkbook.Close False
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
End Sub

 

الكود ده جبته من النت عشان يحفظ شيت واحد فى مكان مختلف بس لما بشغله بيحفظ كل الشيتان  ممكن يكون ايه السبب

[omar elhosseini]

الأخ hesham monzer1

ضع اسم الشيت المراد حفظها في اول سطر من الكود بدلا من ( ورقة1 )

 

 

Const Sh_Name = "ورقة1"

Sub finish()
'
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim xWs As Worksheet
Dim xWb As Workbook
Dim FolderName As String

Application.ScreenUpdating = False

Set xWb = Application.ThisWorkbook
DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
    If xWs.Name = Sh_Name Then
        xWs.Copy
        If Val(Application.Version) < 12 Then
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            Select Case xWb.FileFormat
            Case 51:
                FileExtStr = ".xlsx": FileFormatNum = 51
            Case 52:
                If Application.ActiveWorkbook.HasVBProject Then
                    FileExtStr = ".xlsm": FileFormatNum = 52
                Else
                    FileExtStr = ".xlsx": FileFormatNum = 51
                End If
            Case 56:
                FileExtStr = ".xls": FileFormatNum = 56
            Case Else:
                FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
        xFile = FolderName & "\" & Application.ActiveWorkbook.Sheets(1).Name & FileExtStr
        Application.ActiveWorkbook.SaveAs xFile, FileFormat:=FileFormatNum
        Application.ActiveWorkbook.Close False
    End If
Next
MsgBox "You can find the files in " & FolderName
Application.ScreenUpdating = True
'
End Sub

 

[أحمد يوسف]

أستاذ

hesham monzer1

 

أين الضغط على الإعجاب ؟! 💙