AW: Stamm- u. Monatsdaten sichern (fcs/Franz?)
01.10.2016 05:52:37
fcs
Hallo Gerhard,
inklusive der Daten für den Monat schaut das Makro wie folgt aus.
Gruß
Franz
Sub Stammdaten_sichern()
Dim wksStamm As Worksheet
Dim wksMonat As Worksheet
Dim x As String
Dim scroll_tag As Date
Dim Zeile_L As Long
Dim rngDatum As Range
Dim Datum As Date
Dim varSpalte_1
Dim varSpalte_L
Set wksStamm = ActiveWorkbook.Worksheets("Stammdaten")
x = Format(Range("scroll_tag").Value, "MMMM")
Application.ScreenUpdating = False
'ggf. wird das Monatsblatt neu angelegt werden
If fncCheckSeetName(x, ActiveWorkbook) = False Then
With ActiveWorkbook
.Worksheets.Add after:=.Sheets(.Sheets.Count)
Set wksMonat = ActiveSheet
wksMonat.Name = x
Range("B10").Select
ActiveWindow.FreezePanes = True
End With
Else
If MsgBox("Das Blatt für Monat """ & x & """ existiert bereits!" _
& vbLf & vbLf _
& "Daten überschreiben?", _
vbQuestion + vbOKCancel + vbDefaultButton2, _
"Monatsdaten sichern") = vbCancel Then Exit Sub
Set wksMonat = ActiveWorkbook.Sheets(x)
wksMonat.UsedRange.Clear
wksMonat.Activate
End If
With wksStamm
'Letzte Zeile mit Name
Zeile_L = .Cells(.Rows.Count, 1).End(xlUp).Row
'Spalten A:F kopieren
.Range(.Cells(11, 1), .Cells(Zeile_L, 6)).Copy
End With
With wksMonat
With .Range("A11")
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
'Spalten Monat kopieren
With wksStamm
'Zellbereich mit Datumswerten
Set rngDatum = .Range(.Cells(9, 10), .Cells(9, .Columns.Count).End(xlToLeft))
'1. des Monats
Datum = .Range("scroll_tag").Value
varSpalte_1 = Application.WorksheetFunction.Match(CLng(Datum), rngDatum, 0)
If IsError(varSpalte_1) Then
MsgBox "Datum """ & Datum & """ in Zeile 9 nicht gefunden", _
vbOKOnly, "Suche Startdatum Monat"
Exit Sub
End If
'Letzter des Monats
With .Range("scroll_tag")
Datum = VBA.DateSerial(Year(.Value), Month(.Value) + 1, 0)
End With
varSpalte_L = Application.WorksheetFunction.Match(CLng(Datum), rngDatum, 0)
If IsError(varSpalte_L) Then
MsgBox "Datum """ & Datum & """ in Zeile 9 nicht gefunden", _
vbOKOnly, "Suche Endedatum Monat"
Exit Sub
End If
varSpalte_1 = varSpalte_1 + rngDatum.Column - 1
varSpalte_L = varSpalte_L + rngDatum.Column - 1
.Range(.Cells(9, varSpalte_1), .Cells(Zeile_L, varSpalte_L)).Copy
End With
With .Range("G9")
.PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
End With
With .Range("A2")
.Value = Now
.EntireColumn.AutoFit
.Select
End With
End With
wksStamm.Select 'zurück zum Blatt Worksheets(ActiveSheet.Name)
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub