Sheet opslaan mbv VBA opdracht Knop

[Esducsafe]

Excel Sheet opslaan mbv VBA opdracht Knop

Beste Helpers,
De VBA code om een werkblad op te slaan werkt nog niet helemaal. Zelf geprobeerd e.a. uit te vinden, maar het is mij niet gelukt. Daarom wil ik graag jullie hulp inroepen. Op bijgevoegd bestandje heb ik e.a. uitgewerkt/toegelicht. Alvast bedankt.
mvg
Esko

]

 

[danny147]

Beste Esducsafe

heb je al eens naar deze topic gekeken ?

Groetjes Danny. :thumb:

 

[Esducsafe]

Hallo Danny,
Bedankt voor je inbreng. Helaas, zat de oplossing er volgens mij niet bij.
Heeft iemand nog een idee?
mvg
Esko

 

[danny147]

Beste Esducsafe

Ik zie niet in waarom mijn bestandje niet van pas zou komen.

Ik zou gewoon het tabblad wegschrijven in een nieuw bestandje.
Dan zijn ook alle codes weg in de nieuwe aangemaakte bestanden, minder in bestandsgrootte.

Zeg ook eens wat de bedoeling is ?
Wil je telkens je bestandje met de aangemaakte gegevens wegschrijven onder een andere naam ?

Groetjes Danny. :thumb:

 

[Thankyou]

Of probeer deze topic eens:http://office.webforums.nl/viewtopic.php?t=39459

Zie aldaar ook de opmerking van Redevil.

Succes

 

[MauriceSmit]

Ik gebruik in 1 van mijn calculatie modellen deze optie:
--> ieder tabblad dat je selecteerd worden in een nieuw werkboek gekopieerd (als values). Ideaal voor informatie verspreiding als je de onderliggende calculaties niet wilt prijsgeven.

Option Explicit
Sub Make_Value_Copy()

Dim ReadBook As Workbook
Dim WriteBook As Workbook
Dim ReadSheet As Worksheet
Dim WriteSheet As Worksheet
Dim NewSheetName As String
Dim SelectedSheet() As String
Dim SheetFound As Boolean

Set ReadBook = ActiveWorkbook

Dim i As Integer
i = 0
    For Each ReadSheet In ActiveWindow.SelectedSheets
        ReDim Preserve SelectedSheet(i)
        SelectedSheet(i) = ReadSheet.Name
        i = i + 1
    Next ReadSheet
    ActiveWorkbook.Sheets("Cover Sheet").Select
    
    For i = 0 To UBound(SelectedSheet)
ReEnterName:
        If WriteBook.Name = ReadBook.Name Then Set WriteBook = Application.Workbooks.Add
        NewSheetName = InputBox("Enter the name of the sheet: [" & SelectedSheet(i) & "]", "Enter sheetname", SelectedSheet(i))
        If NewSheetName = "" Then GoTo ReEnterName
        Set WriteSheet = WriteBook.Sheets.Add
        ReadBook.Activate
        ActiveWorkbook.Worksheets(SelectedSheet(i)).Cells.Copy
        WriteSheet.Cells.PasteSpecial xlPasteValues
        WriteSheet.Cells.PasteSpecial xlPasteFormats
        WriteSheet.Name = NewSheetName
    Next i
    
    Application.DisplayAlerts = False
    For Each WriteSheet In WriteBook.Worksheets
        SheetFound = False
        i = 0
        Do Until i = UBound(SelectedSheet) + 1
            If StrComp(SelectedSheet(i), WriteSheet.Name) = 0 Then SheetFound = True
            i = i + 1
        Loop
        If SheetFound = False Then WriteSheet.Delete
    Next WriteSheet
    Application.DisplayAlerts = True

End Sub

 

[Esducsafe]

Beste Maurice,
Bedankt voor je bijdrage, ik ga ermee aan de slag.
Bericht volgt indien .....
mvg
Esko

Ik gebruik in 1 van mijn calculatie modellen deze optie:
--> ieder tabblad dat je selecteerd worden in een nieuw werkboek gekopieerd (als values). Ideaal voor informatie verspreiding als je de onderliggende calculaties niet wilt prijsgeven.

Option Explicit
Sub Make_Value_Copy()

Dim ReadBook As Workbook
Dim WriteBook As Workbook
Dim ReadSheet As Worksheet
Dim WriteSheet As Worksheet
Dim NewSheetName As String
Dim SelectedSheet() As String
Dim SheetFound As Boolean

Set ReadBook = ActiveWorkbook

Dim i As Integer
i = 0
    For Each ReadSheet In ActiveWindow.SelectedSheets
        ReDim Preserve SelectedSheet(i)
        SelectedSheet(i) = ReadSheet.Name
        i = i + 1
    Next ReadSheet
    ActiveWorkbook.Sheets("Cover Sheet").Select
    
    For i = 0 To UBound(SelectedSheet)
ReEnterName:
        If WriteBook.Name = ReadBook.Name Then Set WriteBook = Application.Workbooks.Add
        NewSheetName = InputBox("Enter the name of the sheet: [" & SelectedSheet(i) & "]", "Enter sheetname", SelectedSheet(i))
        If NewSheetName = "" Then GoTo ReEnterName
        Set WriteSheet = WriteBook.Sheets.Add
        ReadBook.Activate
        ActiveWorkbook.Worksheets(SelectedSheet(i)).Cells.Copy
        WriteSheet.Cells.PasteSpecial xlPasteValues
        WriteSheet.Cells.PasteSpecial xlPasteFormats
        WriteSheet.Name = NewSheetName
    Next i
    
    Application.DisplayAlerts = False
    For Each WriteSheet In WriteBook.Worksheets
        SheetFound = False
        i = 0
        Do Until i = UBound(SelectedSheet) + 1
            If StrComp(SelectedSheet(i), WriteSheet.Name) = 0 Then SheetFound = True
            i = i + 1
        Loop
        If SheetFound = False Then WriteSheet.Delete
    Next WriteSheet
    Application.DisplayAlerts = True

End Sub

 

[Esducsafe]

Excel Sheet opslaan mbv VBA opdracht Knop

De door mij gewenste oplossing heb ik aangepast. Het werkblad kan nu in een Map op basis van drie (bv. naam, nummer en periode) in te voeren gegevens opgeslagen worden. Als er al een werkblad (met de zelfde drie gegevens) is opgeslagen, volgt de vraag wilt het bestand .......... Indien Nee, dan kan de opdracht, zonder dat een niet gewenste kopie wordt aan gemaakt, opnieuw worden uitgevoerd. Mijn vraag zet ik nu op opgelost.
Esko

Private Sub CommandButton1_Click()
Dim Bestandsnaam As String
Dim ws As Worksheet
With Sheets("Blad1")
Bestandsnaam = .Range("B7").Value & ".xls"
.Copy
On Error Resume Next
ActiveWorkbook.SaveAs "D:\Dossiers\" & Bestandsnaam, xlNormal
ActiveWorkbook.Close False ' doesn't save any changes
End With
End Sub