AW: Daten beim Einfügen transponieren
17.12.2012 23:59:22
fcs
Hallo Manu,
hier Makros, die erst die Daten konsoliedieren und dann mit Hilfe des AUtofilters für eine Hilfssaplte die Daten zu den einzelnen Mitarbeitern in neue Arbitsmappen kopieren.
Gruß
Franz
Option Explicit
Private wksTag As Worksheet, wksMonat As Worksheet
Private wbkAktiv As Workbook, wbkMonat As Workbook, wksMA As Worksheet
Private SpalteTag As Long, Zeile_MA As Long, SpalteMonat As Long
Private Zeile_M As Long, Zelle As Range, Zelle_MA As Range
Sub MA_Monats_Dateien_erstellen()
Set wbkAktiv = ActiveWorkbook
Call Konsolidieren
Call MA_Dateien_erstellen(strPfad:=wbkAktiv.Path) 'Anpassen
Set wbkMonat = Nothing: Set wksMonat = Nothing
Set wbkAktiv = Nothing: Set wksMA = Nothing: Set wksTag = Nothing: Set Zelle = Nothing
End Sub
Private Sub Konsolidieren()
'Daten aus den Datumsblättern in ein Tabellenblatt übertragen
Application.ScreenUpdating = False
For Each wksTag In wbkAktiv.Worksheets
If IsDate(wksTag.Name) Then
If wbkMonat Is Nothing Then
'Monatsdatei und Monatsblatt anlegen
Application.Workbooks.Add Template:=xlWBATWorksheet
Set wbkMonat = ActiveWorkbook
Set wksMonat = wbkMonat.Worksheets(1)
wksMonat.Name = Format(CDate(wksTag.Name), "MMMM YY")
Set wksMA = wbkMonat.Worksheets.Add(after:=wksMonat)
wksMA.Name = "Liste_MA"
'Titel aus Spalte A des Tages ins Monatsblatt Zeile 2 kopieren
wksTag.Range("A1:A45").Copy
Zeile_M = 3 'Zeile mit Spaltentiteln im Monatsblatt
wksMonat.Cells(Zeile_M, 1).PasteSpecial Paste:=xlPasteAll, Transpose:=True
'Spaltentitel Liste der MA
Zeile_MA = 1
With wksMA
.Cells(Zeile_MA, 1).Value = "MA-Name"
.Range("A2").Select
ActiveWindow.FreezePanes = True
End With
'Spaltenbreiten einstellen
With wksMonat
.Activate
.Columns(1).ColumnWidth = 6
.Columns(2).ColumnWidth = 8
.Columns(3).ColumnWidth = 10
.Columns(4).ColumnWidth = 12
.Range(.Columns(5), .Columns(6)).ColumnWidth = 14
.Range(.Columns(7), .Columns(8)).ColumnWidth = 12
.Columns(9).ColumnWidth = 20
.Range(.Columns(10), .Columns(13)).ColumnWidth = 10
.Columns(14).ColumnWidth = 7
.Range(.Columns(15), .Columns(16)).ColumnWidth = 11
.Columns(17).ColumnWidth = 9
.Columns(18).ColumnWidth = 4
.Columns(19).ColumnWidth = 8.5
.Range(.Columns(20), .Columns(32)).ColumnWidth = 13
.Range(.Columns(33), .Columns(38)).ColumnWidth = 15
.Range(.Columns(39), .Columns(40)).ColumnWidth = 5
.Columns(51).ColumnWidth = 11
.Columns(52).ColumnWidth = 5
.Columns(19).ColumnWidth = 8.5
.Range(.Columns(53), .Columns(55)).ColumnWidth = 15
Range("E4").Select
ActiveWindow.FreezePanes = True
End With
End If
With wksTag
'Letzte Spalte mit Daten in Zeile 1
SpalteTag = .Cells(1, .Columns.Count).End(xlToLeft).Column
.Range(.Cells(1, 2), .Cells(45, SpalteTag)).Copy
End With 'wksTag
With wksMonat
'nächste freie Zeile im Monatsblatt in Spalte A
Zeile_M = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
.Cells(Zeile_M, 1).PasteSpecial Paste:=xlPasteFormats, Transpose:=True
.Cells(Zeile_M, 1).PasteSpecial Paste:=xlPasteValues, Transpose:=True
End With
'Mitarbeiterliste auffüllen
With wksTag
For Each Zelle In wksTag.Range(.Cells(20, 2), .Cells(32, SpalteTag)).Cells
If Zelle.Value "" Then
With wksMA
Set Zelle_MA = .Columns(1).Find(what:=Zelle.Text, LookIn:=xlValues, lookat:=xlWhole) _
If Zelle_MA Is Nothing Then
Zeile_MA = Zeile_MA + 1
.Cells(Zeile_MA, 1).Value = Zelle.Text
End If
End With
End If
Next Zelle
End With
End If
Next wksTag
With wksMonat
'Auswerteformeln für MA in Hilfsspalte einfügen
SpalteMonat = .Cells(3, .Columns.Count).End(xlToLeft).Column + 1
.Cells(3, SpalteMonat) = "Hilfs-Spalte"
Zeile_M = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range(.Cells(4, SpalteMonat), .Cells(Zeile_M, SpalteMonat)).FormulaR1C1 _
= "=IF(COUNTIF(RC20:RC32,R1C1)>0,""X"","""")"
End With
With wksMA
'Liste der Mitarbeiternamen sortieren
With .Range(.Cells(1, 1), .Cells(.Rows.Count, 1).End(xlUp))
If .Rows.Count > 2 Then
.Sort key1:=.Cells(1, 1), Order1:=xlAscending, Header:=xlYes
End If
End With
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Private Sub MA_Dateien_erstellen(ByVal strPfad As String)
'Erstellt für jeden Mitarbeiter eine Datei mit den Monatsdaten im Verzeichnis strPfad
Dim wbkMA As Workbook, wksMuster As Worksheet
' Set wbkMonat = ActiveWorkbook
' Set wksMA = wbkMonat.Worksheets("Liste_MA")
' Set wksMonat = wbkMonat.Worksheets("Monat")
'Mustervorlage erstellen
wksMonat.Copy after:=wksMA
Set wksMuster = ActiveSheet
With wksMuster
.Range(.Cells(4, 1), .Cells(.Rows.Count, 1).End(xlUp)).EntireRow.Delete
.Name = "Monatsdaten"
.Cells(3, 46).Clear
End With
With wksMonat
Zeile_M = .Cells(.Rows.Count, 46).End(xlUp).Row
'in der Hilfsspalte den Autofilter einrichten
.Range(.Cells(3, 1), .Cells(Zeile_M, 46).End(xlUp)).AutoFilter
For Zeile_MA = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
'nächsten Namen aus Liste eintragen
.Range("A1") = wksMA.Cells(Zeile_MA, 1).Value
.Calculate
'Autofilter für Spalte 46 setzen
.AutoFilter.Range.AutoFilter Field:=46
.AutoFilter.Range.AutoFilter Field:=46, Criteria1:="X"
'Musterblatt in neue Mappe kopieren, gefilterte Daten kopieren und Datei speichern
wksMuster.Copy
Set wbkMA = ActiveWorkbook
.Range(.Cells(1, 1), .Cells(Zeile_M, 45)).Copy Destination:=wbkMA.Worksheets(1).Cells(1, _
1)
Application.DisplayAlerts = False
wbkMA.SaveAs Filename:=strPfad & "\" & wksMA.Cells(Zeile_MA, 1).Value & ".xls", _
FileFormat:=xlWorkbook
Application.DisplayAlerts = True
wbkMA.Close
Next
.ShowAllData
.AutoFilterMode = False
End With
End Sub