hier noch mit Tabelle Temp
24.02.2010 16:49:17
Tino
Hallo,
so jetzt werden die Daten auch in die Tabelle Temp ab Q6 mit eingetragen.
Sub test_uhrzeit_einfügen_zelle2()
Dim meArTemp(), meArTabelle(), MeARDatum()
Dim A As Long, NextRow As Long
Dim vCol
Dim ArTab, iSH As Integer
Dim rngTemp As Range
'Tabelle Temp
With Tabelle2
Set rngTemp = .Range("Q6") 'erste Zelle von Liste
rngTemp.Resize(.Cells(.Rows.Count, rngTemp.Column).End(xlUp).Row + 1).ClearContents
End With
'hier die Tabellen anpassen
ArTab = Array("Jan", "Feb", "Mar", "Apr", "Mai", "Jun", "Jul", "Aug", "Sep", "Okt", "Nov", "Dez")
For iSH = Lbound(ArTab) To Ubound(ArTab)
With Sheets(ArTab(iSH))
If .Cells(Rows.Count, 1).End(xlUp).Row > 9 Then
meArTemp = .Range("A10", .Cells(.Rows.Count, 1).End(xlUp)).Resize(, 2).Value2
Redim Preserve meArTemp(1 To Ubound(meArTemp), 1 To 1)
MeARDatum = Range("B9:AF9").Value2
Redim meArTabelle(1 To Ubound(meArTemp) + 1, 1 To Ubound(MeARDatum, 2))
For A = 1 To Ubound(meArTemp)
If IsNumeric(meArTemp(A, 1)) Then
vCol = Application.Match(Fix(meArTemp(A, 1)), MeARDatum, 0)
If IsNumeric(vCol) Then
NextRow = meArTabelle(Ubound(meArTabelle), vCol) + 1
meArTabelle(Ubound(meArTabelle), vCol) = NextRow
meArTabelle(NextRow, vCol) = meArTemp(A, 1) - Fix(meArTemp(A, 1))
End If
End If
Next A
With .Range("B10").Resize(Ubound(meArTabelle) - 1, Ubound(meArTabelle, 2))
.Value = meArTabelle
.NumberFormat = "h:mm:ss"
.EntireColumn.AutoFit
End With
'in Temp Tabelle eintragen
With rngTemp.Resize(Ubound(meArTemp))
.Value = meArTemp 'Daten eintragen
.NumberFormat = "dd/mm/yyyy hh:mm;@" 'Zellen Formatieren
Set rngTemp = rngTemp.Offset(.Cells.Count, 0) 'nächte freie Zelle
End With
End If
End With
Next iSH
End Sub
Gruß Tino