AW: Ich habe auch noch eine Frage!
12.07.2015 17:38:10
Sepp
Hallo Thomas,
also das nicht gefunden wird, kann ich nicht nachvollziehen.
' **********************************************************************
' Modul: Modul1 Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub daten()
Dim vntData As Variant, vntCrit As Variant, vntRet() As Variant
Dim vntCity As Variant, vntSize As Variant, vntGroup As Variant, vntThomas 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
With Sheets("Quelle")
vntData = .Range("A1:T1600")
End With
With Sheets("Zielblatt")
vntCrit = .Range("B1:U4") ' anzahl der zeilen im blatt Quelle
vntCity = .Range("B17")
vntSize = .Range("B18")
vntGroup = .Range("B19")
vntThomas = .Range("B20")
date1 = .Range("B21")
date2 = .Range("B22")
vntExtra = .Range("B23")
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) = vntCity And vntCrit(2, lngCol - 1) = vntSize And _
vntCrit(3, lngCol - 1) = vntGroup And vntCrit(4, lngCol - 1) = vntThomas 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) <= date2 Then
bolDoIt = False
If vntExtra <> "" Then
For lngC = 2 To UBound(vntData, 2)
If vntData(lngRow, lngC) = vntExtra And vntCrit(1, lngC - 1) = vntCity And _
vntCrit(2, lngC - 1) = vntSize And vntCrit(3, lngC - 1) = vntGroup And _
vntCrit(4, lngC - 1) = vntThomas 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)
vntRet(lngI, lngN) = vntData(lngRow, lngCol)
End If
End If
Next
End If
Next
With Sheets("Zielblatt")
.Range("A25").Resize(UBound(vntRet, 1), UBound(vntRet, 2)) = vntRet
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
Gruß Sepp