Such-Prozedur fuer 2-Parameter

hallo zusammen,
In der Datei "Archiv.xls" stehen 52-Tabellen, ab "KW01" bis "KW52".
Gibt es eine Such-Prozedur, die nach 2-Parametern sucht zB:
die Tabellen haben das gleiche Format.In Spalte "F" stehen 4-Stelligezahlen,
auch mit einer führenden Null.In der Nebenspalte "H" stehen 2-Stelligezahlen,
auch hier kann eine führende Null vorhanden sein.
Die 4-Stelligezahlen und die 2-Stelligezahlen stehen immer in der selben Zeile!
Die Suchaktion soll folgendes erledigen:
Ein Eingabefenster fuer die zwei Parameter.
Wenn die gesuchten Parameter einen oder mehrere Treffer in den 52-Tabellen
ergeben,dann sollen die gefundenen Zeilen untereinander in Tabellenblatt
"Auswertung" kopiert werden.
Für Impulse und VBA-Beispiele werde ich euch sehr dankbar sein.
-
marc......

Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Marc,
wie gefällt Dir das?


Sub Marc()
Dim wks As Worksheet, wksZ As Worksheet, _
SuBe As Range, _
Para0 As String, Para1 As String, Para2 As String, fiAd As String, _
laRQ As Long, larZ As Long, _
check As Boolean
Para0 = InputBox(vbCr & vbCr & vbCr & _
"Beide Suchparameter eingeben (1234/12):", "Suchparameter", "1234/12")
Para1 = Left(Para0, 4)
Para2 = Right(Para0, 2)
If Para0 = "" Then check = True
If Len(Para0) <> 7 Then check = True
On Error Resume Next
If Application.IsNumber(CInt(Para1)) = False Then check = True
If Application.IsNumber(CInt(Para2)) = False Then check = True
On Error GoTo 0
If check = True Then
MsgBox "Keine oder falsche Eingabe !" & vbCr & vbCr & _
"Makro-Abbruch !", vbCritical, _
"Dezenter Hinweis für " & Application.UserName & ":"
Exit Sub
End If
Set wksZ = ThisWorkbook.Worksheets("Auswertung")
For Each wks In Worksheets
If Left(wks.Name, 2) = "KW" Then
laRQ = wks.Cells(Rows.Count, 6).End(xlUp).Row
With wks.Range("F1:F" & laRQ)
Set SuBe = .Find(What:=Para1, After:=wks.Range("F" & laRQ), LookIn:=xlValues, LookAt:=xlWhole)
If Not SuBe Is Nothing Then
If SuBe.Offset(0, 2).Text = Para2 Then
larZ = wksZ.Cells(Rows.Count, 6).End(xlUp).Row
If larZ = 1 And wksZ.Cells(1, 6).Value = "" Then larZ = 0
Rows(SuBe.Row).Copy
wksZ.Range("A" & larZ + 1).PasteSpecial Paste:=xlAll
Application.CutCopyMode = False
End If
fiAd = SuBe.Address
Do
Set SuBe = .FindNext(SuBe)
If Not SuBe Is Nothing Then
If SuBe.Address <> fiAd Then
If SuBe.Offset(0, 2).Text = Para2 Then
larZ = wksZ.Cells(Rows.Count, 6).End(xlUp).Row
If larZ = 1 And wksZ.Cells(1, 6).Value = "" Then larZ = 0
Rows(SuBe.Row).Copy
wksZ.Range("A" & larZ + 1).PasteSpecial Paste:=xlAll
Application.CutCopyMode = False
End If
End If
End If
Loop While Not SuBe Is Nothing And SuBe.Address <> fiAd
End If
End With
Set SuBe = Nothing
End If
Next wks
Set wksZ = Nothing
End Sub

Viel Erfolg wünscht
WernerB.
P.S.: Dieses Forum lebt auch von den Rückmeldungen der Fragesteller an die Antworter !

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Such-Prozedur fuer 2-Parameter

1 Beitrag zum Forumthread Beitrag zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

1
Beitrag zum Forumthread

Beitrag zu diesem Forumthread