Formel mit Jahr und Datum automatisch ersetzen

[Rabe]

Hi Willy,

es hilft der Übersichtlichkeit, wenn die Dimensionierung der Variablen am Anfang des Codes erfolgt:

Code:

Option Explicit

Sub Dummydatei()
  Dim Pfadname As String
  Dim fs As Object
  Dim Ordnervorhanden As String
  Dim loA As Long
 
  Pfadname = "D:\Berichte\"
  Pfadname = Pfadname & ActiveSheet.Range("F3")
  ChDrive Pfadname
 
  Set fs = CreateObject("Scripting.FileSystemObject")
  Ordnervorhanden = fs.FolderExists(Pfadname)
  If Ordnervorhanden Then
     ChDir Pfadname
  Else
     Set fs = fs.CreateFolder(Pfadname)
  End If
 
  For loA = ActiveSheet.Range("C2") To Range("D2")
     Pfadname = "D:\Berichte\"
     Pfadname = Pfadname & ActiveSheet.Range("F3")
     ActiveWorkbook.SaveAs Filename:= _
         Pfadname & Format(Str(loA), "00") & ".xls", FileFormat:=xlNormal, _
         Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
         CreateBackup:=False
  Next
  For loA = ActiveSheet.Range("C3") To Range("D3")
     Pfadname = "D:\Berichte\"
     Pfadname = Pfadname & ActiveSheet.Range("F3")
     ActiveWorkbook.SaveAs Filename:= _
         Pfadname & Format(Str(loA), "00") & ".xls", FileFormat:=xlNormal, _
         Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
         CreateBackup:=False
  Next
  Application.Quit
 
End Sub

@All: geht das auch so? Nimmt Excel dann auch die 4 Zellen?

Code:

  For loA = ActiveSheet.Range("C2") To Range("D3")
     Pfadname = "D:\Berichte\"
     Pfadname = Pfadname & ActiveSheet.Range("F3")
     ActiveWorkbook.SaveAs Filename:= _
         Pfadname & Format(Str(loA), "00") & ".xls", FileFormat:=xlNormal, _
         Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
         CreateBackup:=False
  Next

Damit könnte das Makro um 1/4 gekürzt werden.
Und dann noch einen Teil das SaveAs weg:

Code:

Option Explicit

Sub Dummydatei()
   Dim Pfadname As String
   Dim fs As Object
   Dim Ordnervorhanden As String
   Dim loA As Long
  
   Pfadname = "D:\Berichte\"
   Pfadname = Pfadname & ActiveSheet.Range("F3")
   ChDrive Pfadname
  
   Set fs = CreateObject("Scripting.FileSystemObject")
   Ordnervorhanden = fs.FolderExists(Pfadname)
   If Ordnervorhanden Then
      ChDir Pfadname
   Else
      Set fs = fs.CreateFolder(Pfadname)
   End If
  
   For loA = ActiveSheet.Range("C2") To Range("D2")
      Pfadname = "D:\Berichte\"
      Pfadname = Pfadname & ActiveSheet.Range("F3")
      ActiveWorkbook.SaveAs Filename:= _
          Pfadname & Format(Str(loA), "00") & ".xls", FileFormat:=xlNormal
   Next
   Application.Quit
  
End Sub

[snb]

Damit könnte das Makro um 1/4 (??) gekürzt werden.

Code:

Sub M_snb()
   c00="D:\Berichte\" & [F3]
   if dir(c00)="" then mkdir c00

   For j= [C2] To [D2]
      ActiveWorkbook.SaveAs c00 & Format(j, "00") & ".xls", 51
   Next
End Sub

[Rabe]

Code:

Sub M_snb()
  c00="D:\Berichte\" & [F3]
  if dir(c00)="" then mkdir c00

  For j= [C2] To [D2]
     ActiveWorkbook.SaveAs c00 & Format(j, "00") & ".xls", 51
  Next
End Sub

Klasse, noch kürzer! Kann da statt D2 auch D3 geschrieben und dann die Werte von C2, D2, C3 und D3 verwendet werden?

Getestet:
Ja, geht!
Fehlte aber noch das abschließende "\" nach dem Pfadnamen!
c00 = c00 & "\"

[WiK]

Hallo Zusammen,
Ralf dein 3.Code funktioniert super.
bei den nachfolgenden Code, ist c00 blau hinterlegt bei  c00 = "D:\Berichte\" & [F3]".
Was hat die 51 zubedeuten ???
Dim loA As Long kann doch bestimmt raus!

Code:

Option Explicit

Sub Dummydatei()
  Dim Pfadname As String
  Dim fs As Object
  Dim Ordnervorhanden As String
  Dim loA As Long
 
  Pfadname = "D:\Berichte\"
  Pfadname = Pfadname & ActiveSheet.Range("F3")
  ChDrive Pfadname
 
  Set fs = CreateObject("Scripting.FileSystemObject")
  Ordnervorhanden = fs.FolderExists(Pfadname)
  If Ordnervorhanden Then
     ChDir Pfadname
  Else
     Set fs = fs.CreateFolder(Pfadname)
  End If
c00 = "D:\Berichte\" & [F3]
 If Dir(c00) = "" Then MkDir c00

 For j = [C2] To [D2]
    ActiveWorkbook.SaveAs c00 & Format(j, "00") & ".xls", 51
 Next
 Application.Quit
End Sub

Gruß Willy

[Rabe]

Hi Willy,

bei den nachfolgenden Code, ist c00 blau hinterlegt bei  c00 = "D:\Berichte\" & [F3]".
Was hat die 51 zubedeuten ???
Dim loA As Long kann doch bestimmt raus!

- blau vermutlich, weil am Ende das "\" fehlt.
- 51 ist die Datei-Typ-Version von Excel:

51 = xlOpenXMLWorkbook (without macro's in 2007-2013, xlsx)
52 = xlOpenXMLWorkbookMacroEnabled (with or without macro's in 2007-2013, xlsm)
50 = xlExcel12 (Excel Binary Workbook in 2007-2013 with or without macro's, xlsb)
56 = xlExcel8 (97-2003 format in Excel 2007-2013, xls)

- DIM loA kann raus

mit dem Code von snb geht es auch hervorragend:

Sub M_snb()                            'speichert aktuelle Mappe unter den Nummern in C2 bis D3 ab 
Dim c00 As String
Dim j As Long

  c00 = "C:\lokale Daten\" & [F3]      'Pfadname und Verzeichnis 
  c00 = c00 & "\"                      'abschließendes \ 
  If Dir(c00) = "" Then MkDir c00      'Verzeichnis vorhanden, wenn Nein => erzeugen 

  For j = [C2] To [D3]                 'Nummern als Dateinamen 
     ActiveWorkbook.SaveAs c00 & Format(j, "00") & ".xlsx", 51 'abspeichern ohne Makros 
  Next
End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 15 - mit VBAHTML 12.6.0

[snb]

Man braucht die \ nur in letzter Phase.
Blau (wegen 'option explicit' (ausblenden oder löschen, bitte).

Diese Code reicht:

Code:

Sub M_snb()
  c00 = "C:\lokale Daten\" & [F3]
  If Dir(c00) = "" Then MkDir c00

  For j = [C2] To [D3]
    ActiveWorkbook.SaveAs c00 &"\" & Format(j, "00") & ".xlsx", 51
  Next
End Sub

[schauan]

Hallo Willy,

wo steht denn in Deinem code Dim c00 ... ?

[WiK]

Hallo Zusammen,
Danke für die super Hilfe und den Erklärungen.

Andre ich habe es Versucht, aber:

Habe nur sehr sehr bescheidene VBA Kenntnisse, die Code sind alle nur "geklaut".

Den "\" hatte ich in F3 zu stehen, habe ihn jetzt raus gemacht.
Normaler Weise ist der neu zuerstellende Ordner nicht vorhanden, gibt es den Ordner doch ist bei  If Dir(c00) = "" Then MkDir c00 -> MkDir c00 gelb hinterlegt.

For j = [C2] To [D3] geht leider nicht, denn C2 = 20160101  bis D2 = 20160131 und  C3 = 20160201  bis D3 = 20160229 usw. umgewandeltes Datum Format.
Es werden Dateien erzeugt mit 20160132, 20160133 usw. -> siehe #23

Code:

Option Explicit

Sub Dummydatei()
Dim c00 As String
Dim j As Long

 c00 = "D:\Berichte\" & [F3]
 If Dir(c00) = "" Then MkDir c00

 For j = [C2] To [D2]
   ActiveWorkbook.SaveAs c00 & "\" & Format(j, "00") & ".xlsx", 51
 Next
 ...
 For j = [C13] To [D13]
   ActiveWorkbook.SaveAs c00 & "\" & Format(j, "00") & ".xlsx", 51
 Next
 Application.Quit
End Sub

Gruß Willy

[Rabe]

Hi Willy,

For j = [C2] To [D3] geht leider nicht, denn C2 = 20160101  bis D2 = 20160131 und  C3 = 20160201  bis D3 = 20160229 usw. umgewandeltes Datum Format.
Es werden Dateien erzeugt mit 20160132, 20160133 usw. -> siehe #23

ok, ja, klar, da dann das erste Beginn- und das zweite Ende-Datum als Start- und End-Zahl für den Bereich genommen wird und nicht als Datum. Vielleicht könnte auch das Datum als richtiges Datum eingetragen werden und dann beim Abspeichern in die gewünschte Zahl umgewandelt. Dann passiert das nicht bei direkt aufeinanderfolgenden Zeiträumen.

[WiK]

Hallo Ralf,
Danke für den Denkanstoß, das richtige Datum steht in A2 = 01.01.2016, B2 = 31.12.2016. Funktioniert auch mit Schaltjahr.

Code:

For j = [A2] To [B2]
   ActiveWorkbook.SaveAs c00 & "\" & Format(j, "yyyymmdd") & ".xls", 51
 Next

Jetzt fehlt nur noch, sollte der neu zuerstellende Ordner schon vorhanden sein, läuft der Code weiter.( z.Z.  ist dann MkDir c00 gelb hinterlegt)
Dann wäre es perfekt.
Gruß Willy