AW: Arbeitsblatt in neuer Mappe abspeichern
31.12.2018 10:55:00
UweD
Hallo nochmal
dann so....
Sub kopieren()
Dim Pfad As String, Pre As String, Datei As String, Ext As String
Dim Jahr As Integer, KW As String, Lnr As Integer
Dim TB1, TB2, WB2, Rng As String
Set TB1 = ActiveWorkbook.Sheets("Verteilung")
Rng = "A4:U500"
Pre = "Bremen "
Pfad = "Server:\Daten\Lager\Listen\Bestand\" 'mit \ am Ende
Pfad = "X:\Temp\Test\" 'zum Testen
Jahr = Year(Date)
'Verzeichnis vorhanden?
If Dir(Pfad & Jahr, vbDirectory) = "" Then
MsgBox "Verzeichnis '" & Pfad & Jahr & "' fehlt"
Exit Sub
End If
Ext = ".xlsx"
KW = "KW " & WorksheetFunction.WeekNum(Date, 11) & "_"
Do
Lnr = Lnr + 1
Datei = Pfad & Jahr & "\" & Pre & KW & Lnr & Ext
Loop Until Dir(Datei) = ""
'Neue Datei
Set WB2 = Workbooks.Add
Set TB2 = WB2.Sheets(1)
'Bereich kopieren
TB1.Range(Rng).Copy
With TB2.Range(Rng)
.PasteSpecial Paste:=xlPasteAllUsingSourceTheme
.PasteSpecial Paste:=xlPasteColumnWidths
.PasteSpecial Paste:=xlPasteValuesAndNumberFormats
End With
Application.CutCopyMode = False
'Speichern und schließen
WB2.SaveAs Filename:=Datei, FileFormat:=xlOpenXMLWorkbook
WB2.Close
End Sub
Noch ein Tipp
anstelle von
If Target.Cells.Address = "$U$7" Then Range("B29").Select
If Target.Cells.Address = "$U$8" Then Range("B30").Select
If Target.Cells.Address = "$U$9" Then Range("B31").Select
'....
If Target.Cells.Address = "$U$549" Then Range("B571").Select
If Target.Cells.Address = "$U$550" Then Range("B572").Select
If Target.Cells.Address = "$U$551" Then Range("B573").Select
If Target.Cells.Address = "$U$557" Then MsgBox AC & " Verteilung beendet"
If Target.Cells.Address = "$U$558" Then MsgBox AC & " Verteilung beendet"
'....
If Target.Cells.Address = "$U$571" Then MsgBox AC & " Verteilung beendet"
If Target.Cells.Address = "$U$572" Then MsgBox AC & " Verteilung beendet"
If Target.Cells.Address = "$U$573" Then MsgBox AC & " Verteilung beendet"
reicht das.
Microsoft Excel Objekt Tabelle1
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
On Error GoTo Fehler
If Not Intersect(Range("U7:U551"), Target) Is Nothing Then
Application.EnableEvents = False
Target.Offset(22, -19).Select
Application.EnableEvents = True
End If
If Not Intersect(Range("U557:U573"), Target) Is Nothing Then
MsgBox AC & " Verteilung beendet"
End If
'*** Fehlerbehandlung
Err.Clear
Fehler:
Application.EnableEvents = True
If Err.Number <> 0 Then MsgBox "Fehler: " & _
Err.Number & vbLf & Err.Description: Err.Clear
End Sub
LG UweD