AW: Daten erkennen, kopieren u. mehrfach einfügen
08.09.2015 18:31:01
fcs
Hallo Max,
hier das entsprechende Makro angepasst plus eine Function, die prüft ob ein Blatt mit einem schon vorhanden ist.
Gruß
Franz
Private Sub Datenaufbereitung()
Dim wksNeu As Worksheet
Dim rngLohnart As Range
Dim ZeileNeu As Long
On Error GoTo Fehler
Application.ScreenUpdating = False
Application.DisplayAlerts = False
'Bereich mit Lohnarten merken
With ActiveWorkbook.Worksheets("Einstellungen")
Set rngLohnart = .Range(.Cells(2, 3), .Cells(.Rows.Count, 3).End(xlUp))
If rngLohnart.Row = 1 Then
MsgBox "Im Blatt ""Einstellungen"" sind keine Lohnarten eingegeben!"
GoTo Beenden
End If
End With
'Variable Monat ermitteln
Monat = Worksheets("Startblatt").Range("C7").Value
If fncCheckSheetname(Monat) = False Then
MsgBox "Das Blatt mit den Daten für Monat """ & Monat & """ existiert noch nicht!"
GoTo Beenden
End If
'Variable MonatA ermitteln
lngZeile = 65 '"A" = 65. Buchstabe im Zeichensatz
Do Until fncCheckSheetname(Monat & " " & Chr(lngZeile)) = False
lngZeile = lngZeile + 1
If lngZeile = 91 Then
MsgBox "Blattzählung für """ & Monat & """ ist bei ""Z"" angekommen!"
GoTo Beenden
End If
Loop
MonatA = Monat & " " & Chr(lngZeile)
'Erstellen und benennen des Datenblattes mit der Auswertung
With ActiveWorkbook
.Worksheets.Add after:=.Sheets(.Sheets.Count)
End With
Set wksNeu = ActiveSheet
With wksNeu
.Name = MonatA
'Spaltentitel eintragen
.Range("A1").Value = "Personalnummer"
.Range("B1").Value = "Lohnart"
.Range("C1").Value = "Wert"
'Fenster fixieren unter Spaltentitel
.Range("A2").Select
ActiveWindow.FreezePanes = True
'Personalnummern und Lohnarten übertragen
ZeileNeu = 2
With ActiveWorkbook.Worksheets(Monat)
For lngZeile = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
wksNeu.Cells(ZeileNeu, 1).Resize(rngLohnart.Rows.Count, 1) = _
.Cells(lngZeile, 1).Value
wksNeu.Cells(ZeileNeu, 2).Resize(rngLohnart.Rows.Count, 1).Value2 = _
rngLohnart.Value2
ZeileNeu = ZeileNeu + rngLohnart.Rows.Count
Next lngZeile
End With
'Werte ermitteln per Formel
With .Range(.Cells(2, 3), .Cells(ZeileNeu - 1, 3))
.FormulaR1C1 = "=VLOOKUP(RC[-2],'" & Monat & "'!R1:R1048576," _
& "MATCH(RC[-1],'" & Monat & "'!R1,0),FALSE)"
.Calculate
'Formeln durch Werte ersetzen
.Value = .Value
End With
'Spalte mit Lohnarten wieder löschen
.Columns(2).Delete shift:=xlToLeft
'Autofilter einrichten
.Range(.Cells(1, 1), .Cells(ZeileNeu - 1, 2)).AutoFilter
End With
Beenden:
Err.Clear
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description, _
vbOKOnly + vbCritical, "Fehler Makro: Datenaufbereitung"
End Select
End With
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
Public Function fncCheckSheetname(ByVal strSheet As String, _
Optional wkb As Workbook) As Boolean
'Prüft, ob ein Blatt mit dem Namen in der Arbeitsmappe schon vrhanden ist
'True = Blatt vorhanden
'False = Blatt nicht vorhanden
On Error GoTo Fehler
If wkb Is Nothing Then Set wkb = ActiveWorkbook
Set objSheet = wkb.Sheets(strSheet)
fncCheckSheetname = True
Exit Function
Fehler:
fncCheckSheetname = False
End Function