• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Change VBA code

D

dotchieJack

Member
Hello dear helpers,
I have a code that saves every sheet as a file, it works fine, but I would like to change it so it saves every worksheet as a file except the first sheet called Blad1
Thank you in advance
Code:
Code: 
Private Sub CommandButton2_Click()
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, "dd-mm-YYYY")
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 "De bestanden zijn opgeslagen in " & FolderName
Application.ScreenUpdating = True
End Sub
 
Hi
I tested the code and it works fine and it saves all the worksheets to new files ...
You may upload your file ..may be the sheet is protected ..
 

Hi !

Just start the loop from 2 and end with worksheets number …
Just read VBA inner help of Worksheets collection !
​
 
Hi Yasser,
Thank you for your fast reply, I know the code works fine, I only want a small adjusment, that all sheets are saved except the first one called blad1
Thanks
 
So after this line
Code: 
 For Each xWs In xWb.Worksheets

add this line
Code: 
If xWs.Name <> "blad1" Then

And after this line
Code: 
Application.ActiveWorkbook.Close False
and before the Next statement add this line
Code: 
End If
 
Hello Yasser,
Thank you for your reply, unfortunately i get an error Next without For
@Marc, thank you for the reply, but I been trying a few things for the last 2 hours and i can't find the solution
 
Hello Yasser and Marc,
This is my code now and I get the error, what am I doing wrong?
Code: 
Private Sub CommandButton2_Click()
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, "dd-mm-YYYY")
FolderName = xWb.Path & "\" & xWb.Name & " " & DateString
MkDir FolderName
For Each xWs In xWb.Worksheets
If xWs.Name <> "blad1" 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
  If xWs.Name <> "blad1" Then
  End If
Next

MsgBox "De bestanden zijn opgeslagen in " & FolderName
Application.ScreenUpdating = True
End Sub
 
Thank you Yasser and Marc,
It is working fine now
Delete second If codeline …
Click to expand...
I misunderstood the explanation of Yasser (my native language is not English)
Thank you both for the help
Greetz
(problem solved)
 
You must log in or register to reply here.
Back
Top