Microsoft Excel

Herbers Excel/VBA-Archiv

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

Suchen und in Sheets ausgeben

Betrifft: Suchen und in Sheets ausgeben von: Heinz H
Geschrieben am: 27.10.2013 09:40:54

Schönen Sonntag morgen im Forum

Ich habe ein Makro,das mir Teile von Werten sucht,und anzeigt in welchen Zellen die Werte eingetragen sind.

Das funktioniert auch super.

Nur möchte ich die Fundzelle in Sheets "Ausgabe" aufgelistet wird.
ZB. Fund in C5 nun sollte A5:J5 in Sheets"Anzeige" in A2 kopiert werdem.
Bei mehreren Funden sollten alle kobiert werden.

Könnte mir dazu bitte jemand weiterhelfen.

Gruß Heinz


  • Option Explicit
    Sub Suchen()
       Dim rng As Range
       Dim iCounter As Integer
       Dim sSearch As String, sAddress As String, sFirst As String
       Dim bln As Boolean
       sSearch = InputBox("Bitte Suchbegriff eingeben:", , "")
       If sSearch = "" Then Exit Sub
       For iCounter = ActiveSheet.Index - 1 To 1 Step -1
          Set rng = Worksheets(iCounter).Columns("A:K").Find _
             (sSearch, lookat:=xlPart, LookIn:=xlValues)
          If Not rng Is Nothing Then
             sFirst = rng.Address(False, False)
             MsgBox Worksheets(iCounter).Name & "!" & sFirst
             bln = True
             Do Until sAddress = sFirst
                Set rng = Worksheets(iCounter).Columns("A:K").FindNext(after:=rng)
                sAddress = rng.Address(False, False)
                If sFirst <> sAddress Then
                   MsgBox Worksheets(iCounter).Name & "!" & sAddress
                End If
             Loop
             sAddress = ""
             sFirst = ""
          End If
       Next iCounter
       If bln = False Then
          MsgBox "Der Suchbegriff wurde nicht gefunden!"
       End If
    End Sub

  •   

    Betrifft: AW: Suchen und in Sheets ausgeben von: Tino
    Geschrieben am: 27.10.2013 11:49:39

    Hallo,
    kannst mal so versuchen.

    Sub Suchen()
    Dim rng As Range, rngAusgabe As Range
    Dim lngRow As Long
    Dim iCounter As Integer
    Dim sSearch As String, sFirst As String
    Dim AusgabeTabelle As Worksheet
    
    lngRow = 2 'erste Ausgabezeile
    
    With Sheets("Ausgabe")
        'Ausgabe löschen
        .Range(.Cells(lngRow, 1), .Cells(.Rows.Count, 10)).Clear
        Set AusgabeTabelle = Sheets(.Name)
    End With
    
    sSearch = InputBox("Bitte Suchbegriff eingeben:", , "")
    If sSearch = "" Then Exit Sub
    
    For iCounter = ActiveSheet.Index - 1 To 1 Step -1
        With Worksheets(iCounter)
            Set rng = .Columns("A:K").Find(sSearch, lookat:=xlPart, LookIn:=xlValues)
            If Not rng Is Nothing Then
               sFirst = rng.Address
               'Zellen in Zeile A-J
               Set rngAusgabe = rng.EntireRow.Cells(1, 1).Resize(, 10)
               Set rng = .Columns("A:K").FindNext(after:=rng)
               Do Until rng.Address = sFirst
                  'Zellen in Zeile A-J
                  Set rngAusgabe = Union(rng.EntireRow.Cells(1, 1).Resize(, 10), rngAusgabe)
                  Set rng = .Columns("A:K").FindNext(after:=rng)
               Loop
            End If
       End With
       
       If Not rngAusgabe Is Nothing Then
            With AusgabeTabelle
                rngAusgabe.Copy .Cells(lngRow, 1)
                For Each rng In rngAusgabe.Areas
                    lngRow = lngRow + rng.Rows.Count
                Next rng
           End With
           Set rngAusgabe = Nothing
       End If
       
       Set rng = Nothing
       sFirst = ""
    Next iCounter
    End Sub
    Gruß Tino


      

    Betrifft: Danke-Klappt auf Anhieb von: Heinz H
    Geschrieben am: 27.10.2013 11:58:36

    Hallo Tino

    Echt super,hat auf anhieb funktioniert.

    Recht herzlichen Dank.
    Gruß Heinz


      

    Betrifft: Fehler abfangen von: Heinz H
    Geschrieben am: 27.10.2013 16:55:35

    Hallo Tino

    Hätte noch ein kleineres Problem

    Ich habe eine MsgBox eingebaut.
    Wenn nichts gefunden,dann MsgBox.

    Nur läuft die MsgBox bei mir genau verkehrt,also die MsgBox kommt wenn ein Wert gefunden wurde.

    Könntest du mir dazu bitte nochmals weiterhelfen?
    Gruß Heinz


  • Option Explicit
    Sub Suchen()
    Dim rng As Range, rngAusgabe As Range
    Dim lngRow As Long
    Dim iCounter As Integer
    Dim sSearch As String, sFirst As String
    Dim AusgabeTabelle As Worksheet
    
    lngRow = 2 'erste Ausgabezeile
    
    With Sheets("Ausgabe")
        'Ausgabe löschen
        .Range(.Cells(lngRow, 1), .Cells(.Rows.Count, 10)).Clear
        Set AusgabeTabelle = Sheets(.Name)
    End With
    
    sSearch = InputBox("Bitte Suchbegriff eingeben:", , "")
    If sSearch = "" Then Exit Sub
    
    For iCounter = ActiveSheet.Index - 1 To 1 Step -1
        With Worksheets(iCounter)
            Set rng = .Columns("A:K").Find(sSearch, lookat:=xlPart, LookIn:=xlValues)
            If Not rng Is Nothing Then
               
               
               
               
    Fehler:
    MsgBox "ACHTUNG! Fehler aufgetreten! Der gesuchte Wert kann nicht gefunden werden"
    Exit Sub
    
               
               
               
               
               
               sFirst = rng.Address
               'Zellen in Zeile A-J
               Set rngAusgabe = rng.EntireRow.Cells(1, 1).Resize(, 10)
               Set rng = .Columns("A:K").FindNext(after:=rng)
               Do Until rng.Address = sFirst
                  'Zellen in Zeile A-J
                  Set rngAusgabe = Union(rng.EntireRow.Cells(1, 1).Resize(, 10), rngAusgabe)
                  Set rng = .Columns("A:K").FindNext(after:=rng)
               Loop
            End If
       End With
       
       If Not rngAusgabe Is Nothing Then
            With AusgabeTabelle
                rngAusgabe.Copy .Cells(lngRow, 1)
                For Each rng In rngAusgabe.Areas
                    lngRow = lngRow + rng.Rows.Count
                Next rng
           End With
           Set rngAusgabe = Nothing
       End If
       
       Set rng = Nothing
       sFirst = ""
    Next iCounter
    
    Sheets("Ausgabe").Activate
    
    End Sub




  •   

    Betrifft: AW: Fehler abfangen von: Tino
    Geschrieben am: 27.10.2013 17:13:23

    Hallo,
    prüfe die Variable lngRow gleich 2 ist.

    Gruß Tino


      

    Betrifft: Nochmals Danke Tino von: Heinz H
    Geschrieben am: 27.10.2013 17:41:51

    Hallo Tino

    Nochmals recht herzlichen Dank

    Gruß Heinz


      

    Betrifft: AW: Werte nicht löschen von: Heinz H
    Geschrieben am: 31.10.2013 10:15:55

    Hallo Tino

    Dein Makro läuft super.
    Nur wenn ein neuer Wert in Sheets "Ausgabe" eingetragen wird,werden alle anderen Werte gelöscht.

    Ich möchte das die Werte nicht gelöscht werden,sondern bei der ersten freien Zelle ab A2 eingetragen werden.
    Löschen der Werte mache ich dann über ein eigenes Makro.

    Könntest du mir bitte nochmals weiterhelfen?
    Gruß Heinz

  • Option Explicit
    Sub Suchen()
    Dim rng As Range, rngAusgabe As Range
    Dim lngRow As Long
    Dim iCounter As Integer
    Dim sSearch As String, sFirst As String
    Dim AusgabeTabelle As Worksheet
    
    lngRow = 2 'erste Ausgabezeile
    
    With Sheets("Ausgabe")
        'Ausgabe löschen
        .Range(.Cells(lngRow, 1), .Cells(.Rows.Count, 10)).Clear
        Set AusgabeTabelle = Sheets(.Name)
    End With
    
    sSearch = InputBox("Bitte Suchbegriff eingeben:", , "")
    If sSearch = "" Then Exit Sub
    
    For iCounter = ActiveSheet.Index - 1 To 1 Step -1
        With Worksheets(iCounter)
            Set rng = .Columns("A:K").Find(sSearch, lookat:=xlPart, LookIn:=xlValues)
            If Not rng Is Nothing Then
               
               sFirst = rng.Address
               'Zellen in Zeile A-J
               Set rngAusgabe = rng.EntireRow.Cells(1, 1).Resize(, 10)
               Set rng = .Columns("A:K").FindNext(after:=rng)
               Do Until rng.Address = sFirst
                  'Zellen in Zeile A-J
                  Set rngAusgabe = Union(rng.EntireRow.Cells(1, 1).Resize(, 10), rngAusgabe)
                  Set rng = .Columns("A:K").FindNext(after:=rng)
               Loop
            End If
       End With
       
       If Not rngAusgabe Is Nothing Then
            With AusgabeTabelle
                rngAusgabe.Copy .Cells(lngRow, 1)
                For Each rng In rngAusgabe.Areas
                    lngRow = lngRow + rng.Rows.Count
                Next rng
           End With
           Set rngAusgabe = Nothing
       End If
       
       Set rng = Nothing
       sFirst = ""
    Next iCounter
    
    
    If lngRow = 2 Then
               
    Fehler:
    MsgBox "Der gesuchte Wert kann nicht gefunden werden"
    Exit Sub
    
       End If
    Sheets("Ausgabe").Activate
    Sheets("Ausgabe").Cells.EntireColumn.AutoFit
    End Sub




  •   

    Betrifft: AW: Werte nicht löschen von: Tino
    Geschrieben am: 31.10.2013 12:57:58

    Hallo,
    versuch mal und mach aus den Zeilen

         lngRow = 2 'erste Ausgabezeile
         
         With Sheets("Ausgabe")
             'Ausgabe löschen
             .Range(.Cells(lngRow, 1), .Cells(.Rows.Count, 10)).Clear
             Set AusgabeTabelle = Sheets(.Name)
         End With
    diese
         With Sheets("Ausgabe")
             lngRow = .UsedRange.Rows(.UsedRange.Rows.Count).Row + 1
             Set AusgabeTabelle = Sheets(.Name)
         End With
    Gruß Tino


      

    Betrifft: AW: Super - Wie immer von: Heinz H
    Geschrieben am: 31.10.2013 13:01:19

    Hallo Tino

    Perfekt wie immer von dir.

    Recht herzlichen Dank

    Gruß Heinz


     

    Beiträge aus den Excel-Beispielen zum Thema "Suchen und in Sheets ausgeben"