Tabbladen appart opslaan

Status
Niet open voor verdere reacties.
T

Tweety1

Gebruiker
Lid geworden
6 mrt 2013
Berichten
637
Ik heb een Macro die alle Tabbladen opslaat als een nieuwe bestand. Allen kom ik er niet uit hoe ik de volgende kan toevoegen/wijzigen

1. Als ik nu de macro draaie krijg ik steeds de Inputbox ik zou dat graag willen veranderen zodat ik dat maar 1x hoef intevullen.
2. Hoe kan ik de tabbladen overslaan ("Sheet1" en "Totaal", (eerste en laatste tabblad)).
3. Hoe kan ik de betrefende map selecteeren/makken waar de tabbladen moeten worden opgeslagen.

Code: 
Sub SaveAllSheets()
  Dim wbk As Workbook
  Dim wsh As Worksheet
  Set wbk = ActiveWorkbook
  For Each wsh In wbk.Worksheets
  strName = InputBox(Prompt:="Uw naam.", Title:="ENTER YOUR NAME", Default:="Uw naam hier")

    wsh.Copy
    
    ActiveWorkbook.Close SaveChanges:=True, Filename:=wsh.Name & " Tekst  " & strName & "(" & Format(Now, "dd-mm-yyyy") & ")" & ".xlsx"
  Next wsh
End Sub
 
Laatst bewerkt:
Vraag 2 heb kunnen oplossen doormiddel van volgende stukje macro
Code: 
For Each wsh In wbk.Worksheets(Array(2, 3, 4, 5, 6, 7, 8))
 
Vraag 1 heb kunnen oplossen doormiddel van volgende stukje macro
Code: 
Dim strName As String
 
Code: 
Sub SaveAllSheets()
  Dim strName As String, sDir As String
  With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = False
      .InitialFileName = "G:\Mijn documenten\helpmij"
      .Show
      On Error Resume Next
      Err.Clear
      sDir = .SelectedItems(1) & "\"
      If Err.Number <> 0 Then MsgBox "Eerst een Dir selecteren": Exit Sub
  End With
  strName = InputBox(Prompt:="Uw naam.", Title:="ENTER YOUR NAME", Default:="Uw naam hier")
  For i = 2 To Sheets.Count - 1
      Sheets(i).Copy
      ActiveWorkbook.Close SaveChanges:=True, Filename:=sDir & Sheets(i).Name & " Tekst  " & strName & "(" & Format(Now, "dd-mm-yyyy") & ")" & ".xlsx"
  Next
End Sub
 
Ik loop toch nog tegen 1 probleempje aan.
De macro slaat het bestand niet op.
 
Code: 
Sub SaveAllSheets()
  Dim strName As String, sDir As String, FName As String
  With Application.FileDialog(msoFileDialogFolderPicker)
      .AllowMultiSelect = False
      .InitialFileName = "G:\Mijn documenten"
      .Show
      On Error Resume Next
      Err.Clear
      sDir = .SelectedItems(1) & "\"
      If Err.Number <> 0 Then MsgBox "Eerst een Dir selecteren": Exit Sub
  End With
  strName = InputBox(Prompt:="Uw naam.", Title:="ENTER YOUR NAME", Default:="Uw naam hier")
  For i = 2 To Sheets.Count - 1
      FName = sDir & Sheets(i).Name & " Tekst  " & strName & "(" & Format(Now, "dd-mm-yyyy") & ")" & ".xlsx"
      Sheets(i).Copy
      ActiveWorkbook.SaveAs FName, 51
  Next
End Sub
 
Hij slaat het nu wel op alleen werkt de loop/next niet. Hij geeft steeds aan dat het bestand al bestaat.
 
Code: 
  For i = 2 To Sheets.Count - 1
      FName = Sheets(i).Name & " Tekst  " & strName & "(" & Format(Now, "dd-mm-yyyy") & ")" & ".xlsx"
      Sheets(i).Copy
      With ActiveWorkbook
        .SaveAs sDir & FName, 51
        .Close
      End With
  Next
 
De macro werkt goed. Maar hoe kan de macro zo aanpassen dat hij alleen de tabbladen opslaat die een bepaalde tekst bevat.
 
Met Find kan je eerst op elk blad zoeken alvorens op te slaan, maar dan hangt de opbouw v/d macro er ook van af of de tekst in een bepaalde cel staat of ergens op het werkblad.
 
My mistake, je wil dus zoeken op tabbladnamen die een bepaalde tekst bevatten.:o
Kijk hiervoor eens bij de functie InStr waarmee je kan uitzoeken of een string een bepaalde substring bevat.
 
Ik kom er niet helemaal uit. Ik heb volgende stukje toegevoed alleen slaat hij nog steeds alle tabbladen op

Code: 
  If InStr(Sheets(i), "Test") = 0 Then
 
uitzoeken of een string een bepaalde substring bevat
Klik om te vergroten...
Code: 
If InStr(Sheets(i)[COLOR="#FF0000"].Name[/COLOR], "Test") = 0 Then
 
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan