Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema CommandButton
BildScreenshot zu CommandButton CommandButton-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema TextBox
BildScreenshot zu TextBox TextBox-Seite mit Beispielarbeitsmappe aufrufen

Makro für Suchfunktionen

Betrifft: Makro für Suchfunktionen von: erichm
Geschrieben am: 08.11.2014 07:19:11

Hallo,

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 von: Ramses Geschrieben am: 01.03.2003 - 14:13:39
' 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
Danke für eine Hilfe.
mfg

  

Betrifft: AW: Makro für Suchfunktionen von: ransi
Geschrieben am: 08.11.2014 08:28:51

HAllo

Versuch mal: LookIn:=xlValues

Ansonsten verrat uns bitte mal die Fehlermeldung.

ransi


  

Betrifft: AW: Makro für Suchfunktionen von: erichm
Geschrieben am: 08.11.2014 09:41:59

DANKE - Volltreffer! Makro funktioniert!

Jetzt bastle ich an einer Modifizierung:
Aktuell wird in einer Spalte ein Wert gesucht und dann die gefundene Zeile komplett in die Tabelle "Gefunden" kopiert / geschrieben.

Ziel neu: es soll der Wert gefunden werden und dann aus der jeweiligen Zeile nur die Werte aus drei bis vier unterschiedlichen Spalten kopiert werden (in die Tabelle "Gefunden"); Beispiel
- AM = Spalte in der der Wert (= Huber) gesucht wird: Zeilen 20, 30, 175, 250
- AB = 1. Spalte aus der in den betreffenden Zeilen 20, 30, 175, 250 der Wert kopiert wird
- AY = 2. Spalte aus der......
- BA = 3. Spalte aus der......
usw.....

Optimal wäre dann, wenn in der Tabelle "Gefunden" die Ergebnisse so eingetragen werden:
- aus Spalte AM (= Suchspalte des Wertes) in Spalte A
- aus Spalte AB in Spalte B
- aus Spalte AY in Spalte C
usw.....

Danke - das sind meine VBA-Kenntnisse leider nicht ausreichend.

mfg


  

Betrifft: AW: Makro für Suchfunktionen von: Werner
Geschrieben am: 08.11.2014 18:26:04

Hallo,

wks.cells(rng.Row, 28).Copy 'kopiert aus der Fundzeile die Zelle AB (28)
Worksheets(tarWKS).cells(Cr, 2).PasteSpecial...... 'fügt in Zeile Cr in Zelle B (2) ein

Für die anderen analog. - ungetestet -

Gruß Werner


  

Betrifft: DANKE - klappt!! o.w.T von: erichm
Geschrieben am: 09.11.2014 07:47:05

.............


  

Betrifft: AW: DANKE für die Rückmeldung owT von: Werner
Geschrieben am: 09.11.2014 09:04:00