Dateiname aus Zelleninhalt

Hallo liebe Forumgemeinde,
heute bitte ich als absoluter VBA-Anfänger um Hilfe und zwar möchte ich ein gefiltertes Tabellenblatt als eigenständige Datei in dem gleichen Ordner speichern, in der auch die Ursprungsdatei abgelegt ist. Der Dateiname der neu zu speichernden Datei soll sich aus dem gefilterten Tabellenblatt ergeben (Inhalt der Zelle A2).
Die Ursprungsdatei ist gespeichert in D:\Urmel
Inhalt der Zelle A2 = Heinz
Die neu zu speichernde Datei soll demnach wie folgt abgespeichert werden: D:\Urmel\Heinz
Nach dem Speichervorgang soll die neue Datei dann geschlossen werden und das Makro darin enden, dass die Ursprungsdatei und das darin das gefilterte Tabellenblatt Zelle A3 angesprochen wird.
Ich hoffe, dass ich mein Gedankenproblem hinreichend beschrieben habe und bedanke mich schon jetzt für die Hilfe.
Viele Grüße
Andreas

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
gehe davon aus das Du den Autofilter verwendest.
Versuch es mal so. (zum testen)

Sub Test()
Dim rngBereich As Range
Dim strWBName$, sPath$
Dim NewWB As Workbook
Dim oSH As Worksheet
With ThisWorkbook 'Diese Arbeitsmappe
Set oSH = .Sheets("Tabelle1") 'Tabelle anpassen
'Pfad
sPath = IIf(Right$(.Path, 1) = "\", .Path, .Path & "\")
'Dateiextention
strWBName = Mid$(.Name, InStrRev(.Name, "."), Len(.Name))
With oSH
'Dateiname
strWBName = .Range("A2").Value & strWBName
'Filterbereich
Set rngBereich = .AutoFilter.Range
End With
'Neue Datei
Set NewWB = Workbooks.Add(xlWBATWorksheet)
'kopieren
rngBereich.Copy
'einfügen
With NewWB.Sheets(1).Cells(1, 1)
.PasteSpecial xlPasteValues 'Werte
.PasteSpecial xlPasteFormats 'Format
End With
'speichern
On Error Resume Next
Application.DisplayAlerts = False
NewWB.SaveAs sPath & strWBName, .FileFormat
Application.DisplayAlerts = True
'Fehler beim speichern
If Err.Number  0 Then
MsgBox "Fehler Nr.: " & Err.Number & vbCr & vbCr & Err.Description
End If
NewWB.Close False
'gehe zu A3
Application.Goto oSH.Cells(3, 1)
End With
End Sub

Gruß Tino

Sub Test() Dim strWBName$, sPath$ Dim NewWB As Workbook Dim oSH As Worksheet With ThisWorkbook 'Diese Arbeitsmappe Set oSH = .Sheets("Tabelle1") 'Tabelle anpassen 'Pfad sPath = IIf(Right$(.Path, 1) = "\", .Path, .Path & "\") 'Dateiextention strWBName = Mid$(.Name, InStrRev(.Name, "."), Len(.Name)) With oSH 'Dateiname strWBName = .Range("A2").Value & strWBName End With 'Neue Datei oSH.Copy Set NewWB = ActiveWorkbook 'speichern On Error Resume Next Application.DisplayAlerts = False NewWB.SaveAs sPath & strWBName, .FileFormat Application.DisplayAlerts = True 'Fehler beim speichern If Err.Number 0 Then MsgBox "Fehler Nr.: " & Err.Number & vbCr & vbCr & Err.Description End If NewWB.Close False 'gehe zu A3 Application.Goto oSH.Cells(3, 1) End With End Sub

Sub Test() Dim strWBName$, sPath$ Dim NewWB As Workbook Dim oSH As Worksheet With ThisWorkbook 'Diese Arbeitsmappe Set oSH = .Sheets("Tabelle1") 'Tabelle anpassen 'Pfad sPath = IIf(Right$(.Path, 1) = "\", .Path, .Path & "\") 'Dateiextention strWBName = ".xlsx" With oSH 'Dateiname strWBName = .Range("A2").Value & strWBName End With 'Neue Datei oSH.Copy Set NewWB = ActiveWorkbook 'speichern On Error Resume Next Application.DisplayAlerts = False NewWB.SaveAs sPath & strWBName, xlOpenXMLWorkbook Application.DisplayAlerts = True 'Fehler beim speichern If Err.Number 0 Then MsgBox "Fehler Nr.: " & Err.Number & vbCr & vbCr & Err.Description End If NewWB.Close False 'gehe zu A3 Application.Goto oSH.Cells(3, 1) End With End Sub

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

318 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Dateiname aus Zelleninhalt

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

318 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread