Macro von Sepp verändern
28.07.2015 17:38:54
Sepp
ich habe mal wieder ein Problem,
Sepp hatt mir vor kurzem dieses macro erstellt. Nun habe ich ein neues Problem dazubekommen ( Zeitformat). Mit diesem coolen Macro kopiere ich bestimmte Zeilen und Spalten in die Auswertungstabelle. Da die Spalten aber unterschiedliche Formate haben wäre es super wenn ich die Spalten und Zeilen im ausgangs Format wieder in die Auswertungstabelle kopieren könnte. Ich habe das schon mit bedingter Formatierung usw. zu lösen versucht aber es will nicht gelingen. Denn die Spalten verändern sich ja ständig.
kann hier jemand helfen?
liebe grüsse Thomas
Sub daten_holen()
Dim vntData As Variant, vntCrit As Variant, vntRet() As Variant
Dim vntSpesen As Variant, vntKM As Variant, vntPKM As Variant, vntFahrtart As Variant, _
vntStunden As Variant, vnteinnahmen As Variant
Dim date1 As Date, date2 As Date, vntExtra As Variant
Dim lngRow As Long, lngCol As Long, lngC As Long, lngI As Long, lngN As Long
Dim bolDoIt As Boolean
On Error GoTo ErrExit
Worksheets("auswertung").Range("b10:ZZ10").ClearContents ' Formatierung bleibt stehen
Worksheets("auswertung").Range("b11:ZZ10000").ClearContents ' Formatierung mit löschen _
EntireRow.Delete
With Sheets("Vorgang")
vntData = .Range("A1:ek50000") ' Quellblatt
End With
With Sheets("Daten")
vntCrit = .Range("b6:el11") ' Spalten buchstaben müssen Gleich gleiche Anzahl haben el11 _
anpassen wenn mehr kritereien
End With
With Sheets("Filtereinstellungen")
vntSpesen = .Range("h1")
vntKM = .Range("h2")
vntPKM = .Range("h3")
vntFahrtart = .Range("h4")
vntStunden = .Range("h5")
vnteinnahmen = .Range("h6")
date1 = .Range("b18")
date2 = .Range("b19")
vntExtra = .Range("b20")
End With
ReDim vntRet(1 To UBound(vntData, 1), 1 To UBound(vntData, 2))
vntRet(1, 1) = "Datum"
lngN = 1
For lngCol = 2 To UBound(vntData, 2)
If vntCrit(1, lngCol - 1) = vntSpesen And _
vntCrit(2, lngCol - 1) = vntKM And _
vntCrit(3, lngCol - 1) = vntPKM And _
vntCrit(4, lngCol - 1) = vntFahrtart And _
vntCrit(5, lngCol - 1) = vntStunden And _
vntCrit(6, lngCol - 1) = vnteinnahmen Then
lngN = lngN + 1
vntRet(1, lngN) = vntData(1, lngCol)
lngI = 1
For lngRow = 2 To UBound(vntData, 1)
If vntData(lngRow, 8) >= date1 And vntData(lngRow, 8) "" Then
For lngC = 2 To UBound(vntData, 2)
'#### gilt wenn auch wortteile gesucht und gefunden werden sollen
'If LCase(vntData(lngRow, lngC)) Like LCase("*" & vntExtra & "*") And
If vntData(lngRow, lngC) = vntExtra And _
vntCrit(1, lngC - 1) = vntSpesen And _
vntCrit(2, lngC - 1) = vntKM And _
vntCrit(3, lngC - 1) = vntPKM And _
vntCrit(4, lngC - 1) = vntFahrtart And _
vntCrit(5, lngC - 1) = vntStunden And _
vntCrit(6, lngC - 1) = vnteinnahmen Then
bolDoIt = True
Exit For
End If
Next
Else
bolDoIt = True
End If
If bolDoIt Then
lngI = lngI + 1
vntRet(lngI, 1) = vntData(lngRow, 8) ' Datumsspalte 8 = H
vntRet(lngI, lngN) = vntData(lngRow, lngCol)
End If
End If
Next
End If
Next
With Sheets("auswertung")
.Range("b10").Resize(UBound(vntRet, 1), UBound(vntRet, 2)) = vntRet
End With
'##########ab hier sortieren nach Datum ''''''''''''''''''''#
ActiveWorkbook.Worksheets("Auswertung").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Auswertung").Sort.SortFields.Add Key:=Range("b11") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortTextAsNumbers
With ActiveWorkbook.Worksheets("Auswertung").Sort
.SetRange Range("b11:Az1000")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
ErrExit:
With Err
If .Number 0 Then
MsgBox "Fehler in Prozedur:" & vbTab & "'daten'" & vbLf & String(60, "_") & vbLf & vbLf & _
_
IIf(Erl, "Fehler in Zeile:" & vbTab & Erl & vbLf & vbLf, "") & "Fehlernummer:" & vbTab & _
_
.Number & vbLf & vbLf & "Beschreibung:" & vbTab & .Description & vbLf, vbExclamation + _
_
vbMsgBoxSetForeground, "VBA - Fehler in Prozedur - daten"
.Clear
End If
End With
On Error GoTo 0
End Sub