Herbers Excel/VBA-Archiv

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

Such- und Kopierfunktion | Herbers Excel-Forum

• Such- und Kopierfunktion von G.Ludwig vom 28.01.2010 08:39:51
• kannst ja mal testen. - von Tino am 28.01.2010 10:16:44
  • AW: kannst ja mal testen. mT - von G.Ludwig am 28.01.2010 10:38:44
    • unverschämte (?) Ergänzung - von G.Ludwig am 28.01.2010 14:24:00
      • müsste so gehen. - von Tino am 28.01.2010 15:08:37
        • Danke !!! Genial! o.T. - von G.Ludwig am 28.01.2010 15:36:11

Betrifft: Such- und Kopierfunktion von: G.Ludwig
Geschrieben am: 28.01.2010 08:39:51

Liebe Excelaner,

ich möchte aus einem (zunächst) leeren Arbeitsblatt heraus, aus einem anderen Arbeitsblatt ("Teilnehmer.xls") mit mehreren Registern die Zellen die z. B. mit der Zeichenfolge "07-70-NA" beginnen in mein Arbeisblatt kopieren. Die Such- und Kopierfunktion soll alle Registerblätter des zu durchsuchenden Arbeitsblattes erfassen.

Mehrere Versuche mit dem Makrorecorder waren leider unbefriedigend bzw. fehlen mir die Kenntnisse, den erzeugten Code zu verstehen geschweige denn anzupassen.

Ich würde mich freuen, wenn mir jemand dabei helfen mag.

LG aus dem verschneiten Würzburg

Betrifft: kannst ja mal testen. von: Tino
Geschrieben am: 28.01.2010 10:16:44

Hallo,
kannst mal diesen Code testen, Kommentare habe ich dabei geschrieben.

Datei- Pfad anpassen.
Tabelle anpassen wo die Daten hin sollen.

Kommst Du damit zurecht?

Option Explicit
'Hilfsfunktion ***************************** 
Sub FindWerte(ByVal Bereich As Range, ByVal SuchWert, ByRef meAR(), ByRef LCount&)
Dim strStart$, rngRange As Range
'Suchen gesamten inhalt auf Groß- u. Klein- schreibung achten 
Set rngRange = Bereich.Find(What:=SuchWert, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=True, SearchFormat:=False)

If Not rngRange Is Nothing Then
    Do While rngRange.Address <> strStart
            LCount = LCount + 1
            Redim Preserve meAR(LCount)
            meAR(LCount) = rngRange.Value
            If strStart = "" Then strStart = rngRange.Address
            Set rngRange = Bereich.FindNext(rngRange)
    Loop
End If
End Sub

Sub Beispiel_Test()
Dim oWB As Workbook
Dim oSH As Worksheet
Dim meAR(), iCount As Long
Dim rngTemp As Range
Dim NotIsOben As Boolean
Dim strSuchWert As String
Dim LCount As Long

strSuchWert = "07-70-NA*" 'auf den Platzhalter Stern achten 

On Error Resume Next
    'Datei an oWB 
    Set oWB = Workbooks("Teilnehmer.xls")
    If oWB Is Nothing Then 'ist Datei offen? 
     'Datei öffnen Pfad zur Datei anpassen 
     Set oWB = Workbooks.Open("C:\Teilnehmer.xls", ReadOnly:=True)
     NotIsOben = True
    End If
On Error Resume Next

'konnte Datei an oWB übergeben werden? 
If oWB Is Nothing Then
    MsgBox "Datei nicht vorhanden!"
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    
    'Counter auf -1 stellen 
    LCount = -1
    For Each oSH In oWB.Worksheets
        'Suche auf Tabelle mit Parameterübergabe 
        FindWerte oSH.UsedRange, strSuchWert, meAR(), LCount
    Next oSH
    
    If NotIsOben Then
     oWB.Close False
    Else
     ThisWorkbook.Activate
    End If
    
        If LCount > -1 Then 'Daten gefunden 
            'wo die Daten hin sollen ************************************************** 
            'hier auf die Tabelle1 ab A2 
            With Sheets("Tabelle1")
                'leer machen für neue Daten, eventuell löschen wenn nicht gewünscht 
                .Range("A2").Resize(.UsedRange.Rows.Count).ClearContents
                'Daten aus Array einfügen 
                .Range("A2").Resize(Ubound(meAR) + 1) = Application.Transpose(meAR)
            End With
            '************************************************************************** 
        End If
    
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Gruß Tino

Betrifft: AW: kannst ja mal testen. mT von: G.Ludwig
Geschrieben am: 28.01.2010 10:38:44

Hallo Tino,
herzlichen Dank für diese schnelle und funktionierende Lösung; mit den Anpassungen komme ich zurecht. Was wäre ich nur ohne dieses fantastische Forum.
LG und alles Gute
G.Ludwig

Betrifft: unverschämte (?) Ergänzung von: G.Ludwig
Geschrieben am: 28.01.2010 14:24:00

Hallo Tino, liebe Excelaner,

ist es viel Aufwand, den Code dahingehend noch zu ergänzen, dass die Zeile links neben der jeweils gefundenen Zeile noch mit kopiert wird? Das würde vieles erleichtern aber ich kann es leider nicht programmieren.

Dank an alle, die sich damit beschäftigen mögen.

LG
G.Ludwig

Betrifft: müsste so gehen. von: Tino
Geschrieben am: 28.01.2010 15:08:37

Hallo,

'Hilfsfunktion ***************************** 
Sub FindWerte(ByVal Bereich As Range, ByVal SuchWert, ByRef meAR(), ByRef LCount&)
Dim strStart$, rngRange As Range
'Suchen gesamten inhalt auf Groß- u. Klein- schreibung achten 
Set rngRange = Bereich.Find(What:=SuchWert, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=True, SearchFormat:=False)

If Not rngRange Is Nothing Then
    Do While rngRange.Address <> strStart
            LCount = LCount + 1
            Redim Preserve meAR(1 To 2, LCount)
            meAR(1, LCount) = rngRange.Value
            meAR(2, LCount) = rngRange.Offset(0, 1).Value
            If strStart = "" Then strStart = rngRange.Address
            Set rngRange = Bereich.FindNext(rngRange)
    Loop
End If
End Sub

Sub Beispiel_Test()
Dim oWB As Workbook
Dim oSH As Worksheet
Dim meAR(), iCount As Long
Dim rngTemp As Range
Dim NotIsOben As Boolean
Dim strSuchWert As String
Dim LCount As Long

strSuchWert = "07-70-NA*" 'auf den Platzhalter Stern achten 

On Error Resume Next
    'Datei an oWB 
    Set oWB = Workbooks("Teilnehmer.xls")
    If oWB Is Nothing Then 'ist Datei offen? 
     'Datei öffnen Pfad zur Datei anpassen 
     Set oWB = Workbooks.Open("C:\Teilnehmer.xls", ReadOnly:=True)
     NotIsOben = True
    End If
On Error Resume Next

'konnte Datei an oWB übergeben werden? 
If oWB Is Nothing Then
    MsgBox "Datei nicht vorhanden!"
    Exit Sub
End If

With Application
    .EnableEvents = False
    .ScreenUpdating = False
    
    'Counter auf -1 stellen 
    LCount = -1
    For Each oSH In oWB.Worksheets
        'Suche auf Tabelle mit Parameterübergabe 
        FindWerte oSH.UsedRange, strSuchWert, meAR(), LCount
    Next oSH
    
    If NotIsOben Then
     oWB.Close False
    Else
     ThisWorkbook.Activate
    End If
    
        If LCount > -1 Then 'Daten gefunden 
            'wo die Daten hin sollen ************************************************** 
            'hier auf die Tabelle1 ab A2 
            With Sheets("Tabelle1")
                'leer machen für neue Daten, eventuell löschen wenn nicht gewünscht 
                .Range("A2").Resize(.UsedRange.Rows.Count).ClearContents
                'Daten aus Array einfügen 
                .Range("A2").Resize(Ubound(meAR, 2) + 1, Ubound(meAR)) = Application.Transpose(meAR)
            End With
            '************************************************************************** 
        End If
    
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

Gruß Tino

Betrifft: Danke !!! Genial! o.T. von: G.Ludwig
Geschrieben am: 28.01.2010 15:36:11