Suche in ganzer Arbeitsmappe

Hallo liebe VBA-Profis,

ich hab ein Makro (mit meinen sehr bescheidenen VBA-Kenntnissen) geschrieben, das leider nicht ganz so funktioniert wie ich es haben will:

Userbild

Es werden durch das Makro die Nummern die in Mappe1 stehen in Mappe2 gesucht und das jeweilige Datum wird korrigiert (Mappe1 Datum ist richtig).

Hierzu hab ich folgenden Code:

Public Sub DatenKopieren()
    Dim Nummer As String
    Dim StartZelle As Range
    
    Range("$A$2").Select        ' Wählt die Ursprungszelle aus (auch wenn der Curser woanders ist)
    
    ' Schleife, die den Vorgang wiederholt
    Do
        ' hier die Startzelle festsetzen
        Set StartZelle = ActiveCell              
    
        ' Schritt 1: Die aktuelle Zelle kopieren
        StartZelle.Copy
        
        ' Schritt 2: Zur Mappe 2 wechseln
        Workbooks("Mappe2.xlsm").Activate
        
        ' Schritt 3: Den kopierten Inhalt in Mappe 2 suchen
        Nummer = StartZelle.Value
        Cells.Find(What:=Nummer).Activate
        
        ' Schritt 4: Zurück zu Mappe 1 wechseln
        Workbooks("Mappe1.xlsm").Activate
        
        ' Schritt 5: Eine Zelle nach rechts navigieren und Inhalt kopieren
        ActiveCell.Offset(0, 1).Copy
        
        ' Schritt 6: Zu Mappe 2 wechseln
        Workbooks("Mappe2.xlsm").Activate
        
        ' Schritt 7: Zwei Zellen nach rechts navigieren und Inhalt einfügen
        ActiveCell.Offset(0, 2).PasteSpecial
        
        ' Schritt 8: Zurück zu Mappe 1 wechseln und zur nächsten Zahl navigieren
        Workbooks("Mappe1.xlsm").Activate
        ActiveCell.Offset(1, 0).Activate          
        
        ' Überprüfen, ob die Zelle "STOP" enthält
        If ActiveCell.Value = "STOP" Then
            Exit Do ' Schleife beenden, wenn "STOP" gefunden wurde
        End If
    Loop
End Sub

Leider sucht das Makro nur die Zahlen in Mappe2 in der aktuellen Tabelle ich will allerdings, dass es die gesamte Arbeitsmappe durchsucht.
Die Nummern in Mappe2 stehen auch immer in Spalte D, also wäre es vielleicht auch zwecks der Performance das Beste, wenn das Makro in der gesamten Arbeitsmappe nur Spalte D durchsucht und dann das jeweilige Datum ersetzt.

Was genau muss ich hier verändern?

Vielen Dank euch bereits im Voraus!

VG :)

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Public Sub DatenKopieren() Dim StartZelle As Range Dim wb_quell As Workbook Dim wb_ziel As Workbook Set wb_quell = Workbooks("Mappe1.xlsm") Set wb_ziel = Workbooks("Mappe2.xlsm") wbquell.Sheets(1).Range("A2").Select ' Wählt die Ursprungszelle aus (auch wenn der Curser woanders ist) Do ' Schleife, die den Vorgang wiederholt Set StartZelle = wb_quell.ActiveSheet.ActiveCell ' hier die Startzelle festsetzen For i = 1 To wb_ziel.Sheets.Count 'alle sheets der Mappe durchgehen Set gefunden = wb_ziel.Sheets(i).Cells.Find(What:=StartZelle).Activate If Not gefunden Is Nothing Then gefunden.Offset(0, 2).Value = StartZelle.Offset(0, 1).Value Set gefunden = Nothing 'zurücksetzen End If Next i StartZelle.Offset(1, 0).Activate If ActiveCell.Value = "STOP" Then Exit Do ' Schleife beenden, wenn "STOP" gefunden wurde Loop End Sub

Public Sub DatenKopieren() Dim StartZelle As Range Dim wbquell As Workbook Dim wbziel As Workbook Set wbquell = Workbooks("Mappe1.xlsm") Set wbziel = Workbooks("Mappe2.xlsm") wbquell.Sheets(1).Range("A2").Select ' Wählt die Ursprungszelle aus (auch wenn der Curser woanders ist) Do ' Schleife, die den Vorgang wiederholt Set StartZelle = wbquell.ActiveSheet.ActiveCell ' hier die Startzelle festsetzen For i = 1 To wbziel.Sheets.Count 'alle sheets der Mappe durchgehen Set gefunden = wbziel.Sheets(i).Cells.Find(What:=StartZelle).Activate If Not gefunden Is Nothing Then gefunden.Offset(0, 2).Value = StartZelle.Offset(0, 1).Value Set gefunden = Nothing 'zurücksetzen End If Next i StartZelle.Offset(1, 0).Activate If ActiveCell.Value = "STOP" Then Exit Do ' Schleife beenden, wenn "STOP" gefunden wurde Loop End Sub

Public Sub DatenKopieren() Dim rFind As Range, Adr1 As String Dim wb_quell As Workbook, lz1 As Long Dim wb_ziel As Workbook Set wb_quell = Workbooks("Mappe1.xlsm") Set wb_ziel = Workbooks("Mappe2.xlsm") 'Schleife für alle Ziel Tabellen For i = 1 To wb_ziel.Sheets.Count 'LastZell in Quell Tabelle lz1 = wb_quell.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row 'Suche alle Nummern in Ziel Tabelle "i" For Each AC In wb_quell.Sheets(1).Range("A2:A" & lz1) Set rFind = wb_ziel.Sheets(i).Columns(4).Find(What:=AC, After:=[d1], _ LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByColumns, _ SearchDirection:=xlNext, MatchCase:=False) If Not rFind Is Nothing Then Adr1 = rFind.Address Do 'witersuchen bis Ende rFind.Offset(0, 2) = AC.Offset(0, 1) Set rFind = wb_ziel.Sheets(i).Columns(4).FindNext(rFind) Loop Until rFind.Address = Adr1 End If Next AC Next i End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread