Suchen / kopieren von mehreren Blättern

Hallo zusammen.

Ich habe mehrere Arbeitsblätter ( zwischen 1 und 10 Stück, Namen: Table 1-10, Bereich bis max. DZ 1000 ) und brauche eine Funktion, die all diese Blätter nach einem bestimmten Wort (bali:) durchsucht (steht immer am Anfang der betreffenden Zellen) und alle die entsprechenden Zelleninhalte und die Zelleninhalte jeweils rechts von ihr in eine neue, zweispaltige Tabelle auf dem "Arbeitsbereich", also Tabelle 1, untereinander zusammensammelt.

Danach müssen noch alle doppelt vorkommenden Einträge entfernt werden.

Ich habe schon wie wild gegoogelt und mit sverweis, suchen etc probiert, aber das übersteigt meine Fähigkeiten leider.

Hoffentlich kann mir hier jemand helfen.

Beste Grüße

Peter

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

for i = 1 to 10 With Sheets("Table " & i) intersect(.Usedrange, .Range("DZ:EA")).Copy Sheets("Arbeitsbereich").Cells(Rows.Count, 1).End(xlup).Offset(1, 0).PasteSpecial xlpasteall end with next With Sheets("Arbeitsbereich").UsedRange With .Columns(3) .FormulaR1c1 = "=IF(LEFT(RC1,5)="bali:",Row(),0)" .EntireRow.RemoveDuplicates 3, xlno .ClearContents end with .RemoveDuplicates array(1, 2), xlno end with

Sub Suche_nach_Bali() Dim rng As Range For i = 1 To 10 With Sheets("Table " & i) Set rng = Intersect(.UsedRange, .Range("DZ:EA")) 'beschränkt den Bereich For Each cl In rng.SpecialCells(xlConstants) 'geht jede gefüllte Zelle durch 'Suchbegriff wird abgefragt : "Bali:" If InStr(cl, "Bali:") > 0 Then .Range(cl, cl.Offset(0, 1)).Copy Sheets("Arbeitsbereich").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0) Next cl End With Next i Sheets("Arbeitsbereich").UsedRange.RemoveDuplicates Array(1, 2), xlNo End Sub

Sub M_snb() For Each it In Sheets it.Cells.Replace "albi", "=1/0" For Each it1 In it.Cells.SpecialCells(-4123, 16) c01 = it1.Offset(, 1) If InStr(" " & c00 & " ", " " & c01 & " ") Then c00 = c00 & " " & c01 Next it.Cells.SpecialCells(-4123, 16) = "albi" Next MsgBox c00 End Sub

Hallo Peter

ich schicke dir mal zwei Makros zum testen. Das erste ist wie gehabt, prüft aber ob "Bali" immer am Text Anfang steht!
Das zweite Makro listet dir auch doppelte mit der Zelladresse auf, wenn du wissen willst wo du Bali in Table 1-4 findest!

mfg Piet

Option Explicit '19.6.2023 Piet für Herber forum

Sub Suchtext_suchen()
Dim Txt As String, Adr1 As String
Dim SuTxt As String, k As Integer
Dim rFind As Range, c, z As Integer

With Worksheets("Arbeitsbereich")
     .Range("C5:E100").ClearContents
     Application.ScreenUpdating = False
 
     SuTxt = .Range("D3").Value
     c = Len(SuTxt)  'Länge Text
     z = 5  '1-Zeile zum auflisten
     
     For k = 1 To Worksheets.Count
         If Worksheets(k).Name > "Arbeitsbereich" Then
            Set rFind = Worksheets(k).Cells.Find(What:=SuTxt, After:=[a1], LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
            If Not rFind Is Nothing Then
               Adr1 = rFind.Address
                Do  'KEINE doppelten auflisten!
                  '** Bali muss beim Text vorne stehen!!
                  If Left(rFind, c) > SuTxt Then GoTo nx
                  If InStr(Txt, rFind) = 0 Then
                     .Cells(z, 3) = Worksheets(k).Name
                     .Cells(z, 4) = rFind.Value
                     .Cells(z, 5) = rFind.Cells(1, 2)
                      z = z + 1:  Txt = Txt & vbLf & rFind.Value
                  End If
nx:               Set rFind = Worksheets(k).Cells.FindNext(rFind)
               Loop Until rFind.Address = Adr1
            End If
        End If
     Next k
End With
End Sub

Sub Suchtext_suchen_mit_Adresse()
Dim Txt As String, Adr1 As String
Dim SuTxt As String, k As Integer
Dim rFind As Range, c, z As Integer

With Worksheets("Arbeitsbereich")
     .Range("C5:E100").ClearContents
     Application.ScreenUpdating = False
 
     SuTxt = .Range("D3").Value
     c = Len(SuTxt)  'Länge Text
     z = 5  '1-Zeile zum auflisten
     
     For k = 1 To Worksheets.Count
         If Worksheets(k).Name > "Arbeitsbereich" Then
            Set rFind = Worksheets(k).Cells.Find(What:=SuTxt, After:=[a1], LookIn:=xlFormulas, _
                LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=True)
            If Not rFind Is Nothing Then
               Adr1 = rFind.Address
                Do  'doppelte mit Adresse auflisten!
                   If Left(rFind, c) > SuTxt Then GoTo nx
                   Txt = rFind.Address(0, 0)
                   .Cells(z, 3) = Worksheets(k).Name & " " & Txt
                   .Cells(z, 4) = rFind.Value
                   .Cells(z, 5) = rFind.Cells(1, 2)
                    z = z + 1
nx:                Set rFind = Worksheets(k).Cells.FindNext(rFind)
               Loop Until rFind.Address = Adr1
            End If
        End If
     Next k
End With
End Sub

Beliebteste Forumthreads (12 Monate)

Suchen / kopieren von mehreren Blättern

13 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

13
Beiträge zum Forumthread

Beiträge zu diesem Forumthread