Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
916to920
916to920
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Tabellenblätter verteilen und als Datei speichern

Tabellenblätter verteilen und als Datei speichern
22.10.2007 18:11:29
Stefan
Hallo zusammen,
nach langer und erfolgloser Suche im Archiv, muss ich doch einen neuen Beitrag eröffnen.
Ich habe eine .xls Datei, die aus vielen Tabellenblättern besteht. Ich wollte nun fragen, ob es möglich ist, per VBA Programmierung diese Tabellenblätter automatisch in eigene Dateien abzuspeichern?
Es sollte im Prinzip so ablaufen, dass die Tabellenblätter jeweils in einen eigenen Ordner abgelegt. Der Name jedes Ordners entspricht der Zelle C2 aus dem entsprechenden Tabellenblatt, d.h. steht in Tabelle1 in C2 der Wert 1000, soll "Tabelle1" also in den Ordner "1000" abgelegt werden, steht in Tabelle2 der Wert 2000 in C2, soll dieses Tabellenblatt im Ordner "2000" abgelegt werden. Der Speichername der .xls kann dadurch bei allen Dateien gleich sein (in diesem Fall "Kostenverfolgung.xls).
Kann mir da jemand von Euch helfen?
Viele Grüße und vorab schonmal vielen Dank,
Stefan

7
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Tabellenblätter einzeln als Datei speichern
22.10.2007 18:27:55
NoNet
Hallo Stefan,
mit diesem Makro ist das möglich :


Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
    ByVal DirPath As StringAs Long
Sub BlaetterEinzelnSpeichern()
    Dim strVerzeichnis As String
    Dim shBlatt As Worksheet
    strVerzeichnis = "C:\Temp\Excel\" 'mit "\" am Ende !!!
    For Each shBlatt In ActiveWorkbook.Worksheets
        If shBlatt.[C2] <> "" Then
            'Verzeichnis anlegen, falls noch nicht vorhanden !
            MakeSureDirectoryPathExists strVerzeichnis & shBlatt.[C2].Value & "\"
            shBlatt.Copy
            ActiveWorkbook.SaveAs strVerzeichnis & ActiveSheet.[C2].Value & "\Kostenverfolgung.xls"
            ActiveWorkbook.Close False
        Else
            MsgBox shBlatt.Name, vbOKOnly + vbCritical, "Fehlender Dateiname in C2 in Blatt "
        End If
    Next
End Sub


Wenn ein Ordner noch nicht existiert, wird er auch gleich mit angelegt.
Es wird nur geprüft, ob die Zelle C2 des jeweiligen Blattes einen Inhalt hat (für eigenen ORdner), jedoch NICHT, ob es sich dabei um einen gültigen Ordnernamen handelt. Dafür musst Du also schon slebst sorgen...
Gruß, NoNet

Anzeige
Ähnliche Frage!
22.10.2007 18:40:21
Patrick
Ich habe ebenfalls eine Excel-Datei die mehrere Tabellen enthält. Auf einer dieser Tabellen
Sheets("Werte")
hab ich einen Speicherbutten abgelegt, der mir einen Bereich dieser Tabelle als extra Excel-Datei ablegen soll.
Wenn es möglich ist, mit der funktion speichern unter.
Vielen dank im vorraus
gruß Patrick

@Patrick
22.10.2007 19:32:00
Josef
Hallo Patrick,
mach das Nächste mal bitte einen eigenen Thread auf, das ganze wird sonst ziemlich unübersichtlich.
Das sollte es tun.
' **********************************************************************
' Modul: Modul2 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Sub TeilbereichSpeichern()
Dim objWB As Workbook
Dim strRange As String, strFile As String


On Error GoTo ErrExit
GMS

strRange = "A1:F20" 'Bereichsadresse die Kopiert werden soll

strFile = Application.GetSaveAsFilename( _
    fileFilter:="Excel Files (*.xls), *.xls")

If strFile <> "Falsch" Then
    Set objWB = Workbooks.Add(xlWBATWorksheet)
    ThisWorkbook.Sheets("Werte").Range(strRange).Copy
    With objWB.Sheets(1).Range("A1")
        .PasteSpecial xlPasteAll
        .PasteSpecial xlPasteValues
        .PasteSpecial xlPasteFormats
        .PasteSpecial xlPasteColumnWidths
    End With
    Application.CutCopyMode = False
    objWB.SaveAs strFile
    objWB.Close
End If

ErrExit:
GMS True
If Err <> 0 Then MsgBox Err.Description
Set objWB = Nothing
End Sub

Sub GMS(Optional ByVal Modus As Boolean = False)
Static lngCalc As Long

With Application
    .ScreenUpdating = Modus
    .EnableEvents = Modus
    .DisplayAlerts = Modus
    .EnableCancelKey = IIf(Modus, 1, 0)
    If Modus Then
        .Calculation = lngCalc
    Else
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
    End If
    .Cursor = IIf(Modus, -4143, 2)
    .CutCopyMode = False
End With

End Sub

Gruß Sepp

Anzeige
AW: Ähnliche Frage!
25.10.2007 20:52:44
Stefan
Hallo alle zusammen,
ich schmeiß mich weg. Ich war zwei Tage weg und schon habe ich die Lösung erhalten.
An alle, die mir geantwortet haben: vielen herzlichen Dank für Eure Unterstützung!!!
Das ist echt super hier :-)))))
Viele Grüße,
Stefan

AW: Tabellenblätter verteilen und als Datei speichern
22.10.2007 18:35:55
Josef
Hallo Stefan,
probier mal.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************

Option Explicit

Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" _
    (ByVal lpPath As String) As Long

Sub speichern()
Dim objWS As Worksheet
Dim strPath As String, strDir As String, strName As String

strPath = "F:\Temp\Ordner" 'Stammverzeichnis in dem die Ordner angelegt werden sollen
strName = "Kostenverfolgung.xls" 'Dateiname unter dem die Dateien gespeichert werden sollen

If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

For Each objWS In ThisWorkbook.Worksheets
    If objWS.Range("C2") <> "" Then
        strDir = objWS.Range("C2") & "\"
        If MakeSureDirectoryPathExists(strPath & strDir) <> 0 Then
            objWS.Copy
            ActiveWorkbook.SaveAs strPath & strDir & strName
            ActiveWorkbook.Close True
        End If
    End If
Next


End Sub

Gruß Sepp

Anzeige
Fast 1:1 identisch mit meinem Code ;-)) _oT
22.10.2007 18:36:58
NoNet
_oT

Zwei Narren - ein gedanke ;-)) o.T.
22.10.2007 18:52:22
Josef
Gruß Sepp

331 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige