Nachfrage - AW: Suchprogram für Excel
12.02.2015 11:17:39
Klaus
Hallo Oliver,
lege das Makro "FindeAdressen" auf einen Button im Blatt "Übersicht".
Die Zellformatierung wird dabei zerschossen, aber das liegt an deinem Blatt (in Übersicht hat es Rahmen, in Daten hat es keine Rahmen). Rahmen sind mir zu aufwendig.
Sub FindeAdressen()
Const fCol As Long = 1
Const lCol As Long = 6
Const fRow As Long = 3
Const FreeCol As Long = 19
Dim lRow As Long
Dim rSuche As Range
Dim rFinde As Range
Dim SuchWort As String
Const FcopyCol As Long = 1
Const LcopyCol As Long = 17
Const SeeFRow As Long = 10
Dim SeeLRow As Long
With Sheets("Übersicht")
SuchWort = .Range("C5").Value
SeeLRow = .Cells(.Rows.Count, FcopyCol).End(xlUp).Row + 1
.Range(.Cells(SeeFRow, FcopyCol), .Cells(SeeLRow, LcopyCol)).ClearContents
End With
With Sheets("Daten")
.Cells(1, FreeCol).EntireColumn.ClearContents
lRow = .Cells(.Rows.Count, fCol).End(xlUp).Row
For Each rSuche In .Range(.Cells(fRow, fCol), .Cells(lRow, lCol))
If rSuche.Value = SuchWort Then 'hier könnte man statt = auch LIKE einsetzen, um _
unscharfe Suche zu erlauben
.Cells(rSuche.Row, FreeCol).Value = 1
End If
Next rSuche
.Cells(fRow - 1, FreeCol).Value = "FILTER"
Call DoResetAutofilter(Sheets(.Name), FreeCol, FreeCol, fRow - 1)
.Range(.Cells(fRow - 1, FreeCol), .Cells(lRow, FreeCol)).AutoFilter Field:=1, Criteria1:="1" _
.Range(.Cells(fRow, FcopyCol), .Cells(lRow, LcopyCol)).SpecialCells(xlCellTypeVisible).Copy
End With
With Sheets("Übersicht")
.Cells(SeeFRow, FcopyCol).PasteSpecial
Application.CutCopyMode = False
End With
With Sheets("Daten")
.Cells(1, FreeCol).EntireColumn.ClearContents
End With
End Sub
Sub DoResetAutofilter(wksMySheet As Worksheet, iColFirst As Integer, iColLast As Integer, _
lRowFirst As Long)
'* in case a user used another autofiler, this makro resets the autofilter to where needed.
Dim lRowLast As Long
With wksMySheet
lRowLast = .Cells(.Rows.Count, iColFirst).End(xlUp).Row + 1
If .AutoFilterMode Then .Cells.AutoFilter 'Turns OFF Autofilter, if any
.Range(.Cells(lRowFirst, iColFirst), .Cells(lRowLast, iColLast)).AutoFilter 'Turns ON _
Autofilter on given range
End With
End Sub
Grüße,
Klaus M.vdT.
