AW: Spalte speichern unter Name Zelleninhalt
21.12.2020 16:55:04
fcs
Hallo Michael,
mit dem folgenden Makro sollte es funktionieren.
Ich bin nicht 100% sicher, der Speicherort in der von dir gewünschten Form funktioniert.
Zeichne das Speichern einer Datei in dem Ordner mit dem Makro-Rekorder auf, dann siehst du, wie das Verzeichnis im Code angegeben werden muss.
LG
Franz
Sub Speichern_SpalteN_ab_Zeile_3()
Dim strOrdner As String, strDatei As String
Dim wks As Worksheet
Dim rngCopy As Range
Dim strDateiCheck As String, varNr, varNrMax
Dim wkbNeu As Workbook
strOrdner = "C:\Users\Public\Test\Test2" 'Zielordner
strOrdner = "\\172.20.120.76\Daten" 'Zielordner
Set wks = ActiveSheet
With wks
'zu kopierender Zellbereich in Spalte N (14)
Set rngCopy = .Range(.Cells(3, 14), .Cells(.Rows.Count, 14).End(xlUp))
strDatei = .Range("O1").Text
End With
'prüfen, ob vorgegebener Name bereits im Ordner vorhanden
strDateiCheck = Dir(strOrdner & "\" & strDatei & ".xlsx", vbNormal)
If strDateiCheck = "" Then
'neuer Dateiname
strDatei = strOrdner & "\" & strDatei & ".xlsx"
Else
'alle Datein finden, die mit dem gleichen Namen beginnen
strDateiCheck = Dir(strOrdner & "\" & strDatei & "*.xlsx", vbNormal)
Do Until strDateiCheck = ""
'max. Zählnummern vor dem Punkt der Dateinamenserweiterung ermitteln
strDateiCheck = Replace(strDateiCheck, strDatei, "")
If Left(strDateiCheck, 1) = "." Then
varNr = 0
Else
varNr = Val(Left(strDateiCheck, InStr(1, strDateiCheck, ".") - 1))
End If
If varNr > varNrMax Then varNrMax = varNr
strDateiCheck = Dir
Loop
'Zählnummer erhöhen
varNrMax = varNrMax + 1
'neuer Dateiname - Zählnummern mit führender Null
strDatei = strOrdner & "\" & strDatei & Format(varNrMax, "00") & ".xlsx"
End If
'neue Mappe mit einem Tabellenblatt öffnen
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wkbNeu = ActiveWorkbook
With wkbNeu.Worksheets(1)
.Name = rngCopy.Parent.Name 'gleicher Blattname wie in aktiver Arbeitsmappe
rngCopy.Copy
With .Range("A1") 'Einfüge-Zelle im Zielblatt
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteFormats
.PasteSpecial Paste:=xlPasteValues
End With
End With
Application.CutCopyMode = False
wkbNeu.SaveAs Filename:=strDatei, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False, _
addtomru:=True
wkbNeu.Close savechanges:=False
End Sub