AW: Datei in anderem Ordner neu erstellen
07.01.2018 23:00:57
fcs
Hallo Michael,
nachfolgend ein entsprechender Satz von Makros
Die Nr. 6 - Formeln anpassen - kann nach meiner Einschätzung im Makro weggelassen werden, da sich die Formeln mit der Umbenennung der Blätter automatisch anpassen.
Den gesamten Code kopierst du am besten in ein neues Modul in deiner persönlichen Makroarbeitsmappe.
Dann kannst du deine vorhandenen Dateien makrofrei lassen.
Gruß
Franz
'Code in einem allgemeinen Modil
'2019-01-07 erstellt unter Office Pro 2010 - Excel 2010 - Windows Vista
Option Explicit
Private wkbOrig As Workbook, wkbNeu As Workbook
Private wksOrig1 As Worksheet, wksOrig2 As Worksheet, wksNeu1 As Worksheet, wksNeu2 As _
Worksheet
Private varNameNeu, varPfadNeu
Private intKW As Integer, intJahr As Integer
Public Sub Statistik_Neue_Datei()
Dim StatusCalc As Long
Set wkbOrig = ActiveWorkbook
Call subNeueDatei_erstellen
If varPfadNeu = "" Or varNameNeu = "" Then
MsgBox "Bitte erst die neue Datei erstellen", vbOKOnly, "Neue Datei erstellen"
Else
'Makrobremsen lösen
With Application
.ScreenUpdating = False
StatusCalc = .Calculation
.Calculation = xlCalculationManual
End With
Set wksOrig1 = wkbOrig.Worksheets(1)
Set wksOrig2 = wkbOrig.Worksheets(2)
'Neue Datei öffnen
Set wkbNeu = Application.Workbooks.Open( _
Filename:=varPfadNeu & Application.PathSeparator & varNameNeu)
Set wksNeu1 = wkbNeu.Worksheets(1)
Set wksNeu2 = wkbNeu.Worksheets(2)
'Tabellenblätter in Neuer Datei umbenennen
wksNeu1.Name = Format(intKW, "00") & "-" & Right(intJahr, 2)
wksNeu2.Name = "KW" & Format(intKW, "00")
With wksNeu1
'Konstanten im Bereich löschen
.Range("C6:I17").SpecialCells(xlCellTypeConstants).ClearContents
'Datum des Montags der 1. KW im Jahr eintragen
.Range("C5").Value = fncDatumKW_DE(intJahr, 1, 1)
End With
With wksNeu2
'Jahr eintragen
.Range("L2").Value = intJahr
'Formeln anpassen in Zell-Bereichen C11:C17; D11:D17; E11:E17; G11:G17; E24; E30; _
E35; L9
'sollte nicht erforderlich sein _
mit der Umbenennung des Tabellenblatts werden Formeln automatisch angepasst
'Daten aus Originaldatei in neue Datei übernehmen
.Range("F21") = wksOrig2.Range("E21").Value
.Range("F24") = wksOrig2.Range("E24").Value
.Range("F30") = wksOrig2.Range("E30").Value
.Range("F35") = wksOrig2.Range("E35").Value
End With
'Makrobremsen zurücksetzen
With Application
.ScreenUpdating = True
.Calculation = StatusCalc
End With
End If
'Variablen zurücksetzen
varNameNeu = "": varPfadNeu = ""
Set wkbOrig = Nothing: Set wksOrig1 = Nothing: Set wksOrig2 = Nothing
Set wkbNeu = Nothing: Set wksNeu1 = Nothing: Set wksNeu2 = Nothing
End Sub
Private Sub subNeueDatei_erstellen()
Dim strZ As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Ordner für neue Datei auswählen bzw. erstellen"
If .Show = -1 Then
varPfadNeu = .SelectedItems(1)
EingabeNameNeu:
varNameNeu = VBA.InputBox(Prompt:="Name der neuen Datei?", _
Title:="Neue Arbeitsmappe für KW01 erstellen", _
Default:="Auszahlungsstatistik KW01-2019")
If varNameNeu = False Or varNameNeu = "" Then
varNameNeu = ""
Else
strZ = ""
If fncheckFilename(varNameNeu, strZ) = False Then
MsgBox "Der Dateiname """ & varNameNeu & """ enthält unzulässige(s) Zeichen _
" _
& strZ, _
vbOKOnly + vbInformation, "Neue Datei erstellen-Prüfen Dateiname"
GoTo EingabeNameNeu
End If
If varNameNeu Like "* KW##-####" Then
intKW = Val(Left(Right(varNameNeu, 7), 2))
intJahr = Val(Right(varNameNeu, 4))
If intKW 53 Then
MsgBox "Unzulässige KW """ & intKW & """ im Dateinamen!", _
vbInformation + vbOKOnly, "Datei neu erstellen-Prüfen Dateiname"
GoTo EingabeNameNeu
ElseIf intJahr "" Then
If MsgBox("Die Datei " & vbLf _
& varPfadNeu & Application.PathSeparator & varNameNeu & vbLf _
& "existiert schon" & vbLf & "Datei überschreiben?", _
vbOKCancel + vbQuestion, _
"Neue Datei erstellen") = vbCancel Then
varNameNeu = ""
GoTo weiter01
End If
End If
'neue Datei erstellen
wkbOrig.SaveCopyAs Filename:=varPfadNeu & Application.PathSeparator & _
varNameNeu
weiter01:
End If
Else
varPfadNeu = ""
End If
End With
End Sub
Public Function fncDatumKW_DE(ByVal intJahr As Integer, _
Optional ByVal intKW As Integer = 1, _
Optional ByVal intWT As Integer = 1) As Date
'Ermittelt das Datum eines Wochentags in einer KW für Deutschland
'intKW = Nummer der Kalenderwoche
'intWT = Wochentag - 1 = Mo, 2 = Di, ..., 7 = So
Dim WT_Jan_01 As Integer
Dim datDatum As Date
datDatum = VBA.DateSerial(intJahr, 1, 1) '1. Januar des Jahres
WT_Jan_01 = VBA.Weekday(datDatum, vbMonday)
If WT_Jan_01 ")
fncheckFilename = True
For i = LBound(arrZeichen) To UBound(arrZeichen)
If InStr(1, strName, arrZeichen(i)) > 0 Then
strZ = strZ & " " & arrZeichen(i)
End If
Next
If Not VBA.IsMissing(varNotDesired) Then
For i = LBound(varNotDesired) To UBound(varNotDesired)
If InStr(1, strName, varNotDesired(i)) > 0 Then
strZ = strZ & " " & varNotDesired(i)
End If
Next
End If
If strZ "" Then fncheckFilename = False
End Function