Makro:Monatsblätter in Liste umbauen
Aus XIMES
Inhaltsverzeichnis |
Was tut es?
Liest aus einer Datei in der viele Blätter mit Monatsdaten mit Aufbau
März 2005 Name 1 2 3 4 5 6 7 8 ... Maier U F F S N N - - Huber F F F S N N - -
Daten ein und stellt sie auf Blatt Result mit Aufbau
Name Datum Schicht
Maier 1.3.2005 U
Maier 2.3.2005 F
Maier 3.3.2005 F
...
Huber 1.3.2005 F
...
Typisch erfolgt danach die verbindung zu den Schichtzeiten bzw. Schichtstunden mit SVERWEIS bzw. VLOOKUP oder in TIS. ZB mit
=SVERWEIS(C2;List!$A$6:$H$55;8;FALSCH) ... in List!$A$6:$H$55 spalte 8 stehen die Stunden der Dienste
Achtung
Es können mehr als die berühmten 65534 Zeilen entstehen. Dann tritt Fehler auf.
Lösung Datei zerlegen und wiederholen.
Makro
Option Explicit
' Liest aus einer Datei in der viele Blätter mit Monatsdaten mit Aufbau
' März 2005
' Name 1 2 3 4 5 6 7 8 ...
' Maier U F F S N N - -
' Huber F F F S N N - -
'
' Daten ein und stellt sie auf Blatt Result mit Aufbau
' Name Datum Schicht
' Maier 1.3.2005 U
' Maier 2.3.2005 F
' Maier 3.3.2005 F
' ...
' Huber 1.3.2005 F
' ...
'NICHT VERGESSEN
' Blatt mit Name Result anlegen
' Adressbezüge anpassen
' Prüfen das alle Blätter gleich von Zeilen anfangen
Sub GetData()
Dim sh As Worksheet
Dim werte As Range
Dim result As Range
Dim i, j As Integer
Dim printline As Long
Dim Datumstring As String
Set result = Worksheets("Result").Cells
result.ClearContents
result(1, 1) = "Name"
result(1, 2) = "Datum"
result(1, 3) = "Dienst"
printline = 2
For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "Result" Then
Set werte = sh.Cells
'***ANPASSEN Spalten wo Datum steht
For i = 2 To 32
If IsNumeric(werte(2, i)) Then
'***ANPASSEN woher bekomme ich Monat und Jahr
Datumstring = Year(werte(2, 1)) & "." & Month(werte(2, 1)) & "." & werte(2, i)
'***ANPASSEN wie viel Zeilen könnte was stehen, wo beginnen Einträge
For j = 3 To 200
If werte(j, 1) <> "" Then
printquick result, printline, werte(j, 1), Datumstring, werte(j, i)
End If
Next
End If
Next
End If
Next
End Sub
Hilfsfunktion
'Hilfsfunktion für Ausgabe
Private Sub printquick(wohin As Range, line As Long, text As String, datum As Variant, Dienst As Variant, Optional bGeheNächsteZeile As Boolean = True)
'
wohin(line, 1) = text
wohin(line, 2) = datum
wohin(line, 3) = Dienst
'
If bGeheNächsteZeile Then line = line + 1
'
End Sub
