AW: Suchfunktion erweitern
17.03.2019 08:37:21
fcs
Hallo MK-184,
nachfolgend ein entsprechendes Makro. Ergebnis wird in einer MsgBox ausgegeben.
LG
Franz
'Code in einem allgemeinen Modul
Option Explicit
Private arrFound(), intF As Integer
Sub SucheSpezial()
Dim wkbMaster As Workbook, wkb2 As Workbook
Dim Zeile As Long
Dim strDatei2 As String
Dim MsgText As String
Dim varSuche1, varSuche2, varSuche3
Erase arrFound: intF = 0
Set wkbMaster = ActiveWorkbook
Zeile = ActiveCell.Row
With ActiveSheet
varSuche1 = .Cells(Zeile, 3).Value 'Name
varSuche2 = .Cells(Zeile, 4).Value 'Vorname
varSuche3 = .Cells(Zeile, 8).Value 'Geburtsdatum
End With
If varSuche1 = "" Then
MsgBox "Zelle für Name enthält keinen Wert"
Exit Sub
End If
If varSuche2 = "" Then
MsgBox "Zelle für Vorname enthält keinen Wert"
Exit Sub
End If
If varSuche3 = "" Then
MsgBox "Zelle für Geburtsdatum enthält keinen Wert"
Exit Sub
End If
Application.ScreenUpdating = False
Call prcSucheSpezial(wkbMaster, 3, varSuche1, 4, varSuche2, 8, varSuche3, wksNot:= _
ActiveSheet.Name)
strDatei2 = wkbMaster.Path & "\" & "SucheDatei 2.xlsx" 'Pfad und Name anpassen !!!
Set wkb2 = Application.Workbooks.Open(Filename:=strDatei2, ReadOnly:=True)
Call prcSucheSpezial(wkb2, 3, varSuche1, 4, varSuche2, 8, varSuche3, wksNot:="")
wkb2.Close savechanges:=False
If intF = 0 Then
MsgText = "gesuchter Name, Vorname Geburtdatum nicht gefunden!"
Else
MsgText = "gesuchter Name, Vorname Geburtdatum gefunden in:" & vbLf _
& "Datei - Blatt - Zeile"
For intF = 1 To UBound(arrFound, 2)
MsgText = MsgText & vbLf & arrFound(1, intF) & " - " & arrFound(2, intF) _
& " - " & arrFound(3, intF)
Next
End If
Application.ScreenUpdating = True
Erase arrFound: intF = 0
MsgBox MsgText, vbInformation + vbOKOnly, "ErgebnisSpezialsuche"
End Sub
Sub prcSucheSpezial(wkb As Workbook, Spa_1 As Long, varWert1, Spa_2 As Long, varWert2, _
Spa_3 As Long, varWert3, Optional wksNot As String)
Dim wks As Worksheet
Dim rngFound As Range
Dim FirstAddress As String
For Each wks In wkb.Worksheets
Select Case LCase(wks.Name)
Case LCase(wksNot)
Case Else
Set rngFound = wks.Columns(Spa_1).Find(What:=varWert1, LookIn:=xlValues, lookat:= _
xlWhole, _
searchdirection:=xlNext)
If rngFound Is Nothing Then
'Name nicht in Spalte C gefunden
Else
FirstAddress = rngFound.Address '1. Fund Zelle merken
Do
'Suchbegriffe in Spalte D und H verleichen
If wks.Cells(rngFound.Row, Spa_2) = varWert2 _
And wks.Cells(rngFound.Row, Spa_3) = varWert3 Then
intF = intF + 1
ReDim Preserve arrFound(1 To 3, 1 To intF)
arrFound(1, intF) = wkb.Name
arrFound(2, intF) = wks.Name
arrFound(3, intF) = rngFound.Row
End If
Set rngFound = wks.Columns(Spa_1).FindNext(after:=rngFound)
If rngFound.Address = FirstAddress Then Exit Do
Loop
End If
End Select
Next
End Sub