Makro für Suchfunktionen
08.11.2014 07:19:11
erichm
hatte mir vor Jahren mit Hilfe dieses Forums diverse Makros gebastelt, mit denen ich Werte / Worte in einer Tabelle gesucht habe und dann die betroffenen Zeilen in eine eine neue Tabelle übertragen habe - das war in EXCEL2003.
Die Makros hatte ich lange nicht mehr benutzt und benötige sie jetzt wieder - in EXCEL2013.
Jetzt muss ich wohl meine Makros anpassen. Bei diesem hier bleibt das Makro dort stehen und wird gelb markiert:
Set rng = wks.Columns(mySpalte).Find(What:=sFind, LookAt:=xlWhole, LookIn:=xlValue) 'xlFormulas
Das komplette Makro:
Private Sub CommandButton1_Click()
' https://www.herber.de/forum/ _
archiv/224to228/t225904.htm
' Re: suchen und kopieren ' mehrmals geändert Erich M., Nepumuk
Dim zeile1 As Long, zeile2 As Long, zeile3 As Long, Tab1 As Worksheet, Tab2 As Worksheet
Dim myName1 As String, Auswahl As String, myDatei As String
Dim myWert1 As String, myWert2 As String, mySpalte As Integer
Dim myName2 As String, gefunden As Boolean
Dim Zelle As Range, Tb(1 To 15) As Worksheet, zeile As Long
Dim wks As Worksheet
Dim rng As Range
Dim sAddress As String, sFind As String
Dim Cr As Long, tarWks As String
If ComboBox1.Text = "" Then MsgBox "Bitte Datei auswählen.", 48, "Hinweis": Exit Sub
If ComboBox2.Text "" Then Set Tb(1) = Workbooks(ComboBox1.Text).Worksheets(ComboBox2. _
Text) Else MsgBox "Bitte Tabellenblatt 1 auswählen.", 48, "Hinweis": Exit Sub
If ComboBox4 = "" Then MsgBox "Bitte Suchspalte auswählen.", 48, "Hinweis": Exit Sub
' Umwandlung Spalte Buchstabe in Zahl
Dim strBuchstaben As String, intNummer As Integer, letzteSpalte As Integer
strBuchstaben = ComboBox4.Text
If Len(strBuchstaben) = 1 Then
intNummer = Asc(strBuchstaben) - 64
Else
intNummer = (Asc(Left(strBuchstaben, 1)) - 64) * 26
intNummer = intNummer + Asc(Right(strBuchstaben, 1)) - 64
End If
letzteSpalte = CStr(intNummer)
myDatei = ComboBox1.Text 'Datei in der gesucht wird
myWert1 = TextBox1.Text 'Suchbegriff Wert
myName1 = ComboBox2.Text 'Suchtabelle
mySpalte = letzteSpalte 'Suchspalte in Suchtabelle 'bisher:ComboBox4.Text
Workbooks(ComboBox1.Text).Activate
Sheets(ComboBox2.Text).Select
Range("A1").Select
Set Tab1 = Sheets(ComboBox2.Text) ' = Ausgangstabelle, Suchtabelle
TabAuswahl
Sheets("Gefunden").Cells.Clear
Sheets("Gefunden").Cells(1, 1) = "Der Wert " & Auswahl & " " & myWert1 & _
" wurde in der Datei " & myDatei & ", Tabelle " & myName1 & _
", in der Spalte " & mySpalte & " gefunden"
Sheets("Gefunden").Cells(2, 1) = "'"
Set Tab2 = Sheets("Gefunden") ' = Eingabetabelle
sFind = myWert1
If sFind = "" Then Exit Sub
tarWks = "Gefunden" ' Zieltabelle
Cr = 65536
If Worksheets(tarWks).Cells(Cr, 1) = "" Then
Cr = Worksheets(tarWks).Cells(Cr, 1).End(xlUp).Row
End If
If Cr = 2 Then Cr = 3
Set wks = Worksheets(myName1)
Set rng = wks.Columns(mySpalte).Find(What:=sFind, LookAt:=xlWhole, LookIn:=xlValue) ' _
xlFormulas
If Not rng Is Nothing Then
sAddress = rng.Address
Do
Application.Goto rng, True
' If MsgBox("Weiter und kopieren", vbYesNo + vbQuestion) = vbNo Then Exit Sub
wks.Rows(rng.Row).Copy Destination:=Worksheets(tarWks).Rows(Cr)
wks.Rows(rng.Row).Copy 'neu
Worksheets(tarWks).Rows(Cr).PasteSpecial Paste:=xlValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False 'neu
Application.CutCopyMode = False 'neu
Cr = Cr + 1
Set rng = wks.Columns(mySpalte).FindNext(After:=ActiveCell)
If rng.Address = sAddress Then Exit Do
Loop
End If
Unload Me
Sheets("Gefunden").Activate
Sheets("Gefunden").Activate
Worksheets("Gefunden").Select
ActiveWindow.FreezePanes = False
Range("B3").Select
ActiveWindow.FreezePanes = True
Range("A1:I1").Select
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlThick
.ColorIndex = 3 'xlAutomatic
End With
Range("2:2").Select
Selection.RowHeight = 6
Range("J1").Select
'Range("B2").Select
'ActiveWindow.FreezePanes = True
'Range("J1").Select
End Sub
mfg