Suchen von gleichen Zellen in zwei Tabellen und kopieren von Daten

[JimmyJoe]

Super!!!!!!!!!!!!!!!! :23:
Jetzt kann ich es halbwegs nachvollziehen.
Ist es noch möglich in Tabelle1 die Zellen Rot zu markieren die es nicht gefunden hat?

[atilla]

Hallo,

Stefans Code so erweitert müsste Deinem Wunsch entsprechen:

Code:

Sub prcKopieren()
   Dim lngC As Long, lngZ As Long
   Dim rngSuche As Range
  
  Application.ScreenUpdating = False 'Bidschirmaktuallisierung aus
   With Worksheets("Tabelle1")
      lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row  'letzte belgte Zeile in Spalte A
      .Range("A3:A" & lngZ).Interior.ColorIndex = xlNone 'A3:A bis letzte belegte Zeile Farben raus
      'eine Schleife durch die Spalte A der Tabelle1 bis zum Ende
      For lngC = 3 To lngZ
         If InStr(.Cells(lngC, 1), "Überschrift") = 0 Then   'wenn Zelle nicht "Überschrift"
            'der Wert aus der Zelle A... wird in der Tabelle Rohdaten gesucht
            Set rngSuche = Worksheets("Rohdaten").Columns(1).Find(.Cells(lngC, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
            'wenn der Wert in der Tabelle Rohdaten gefunden wird
            If Not rngSuche Is Nothing Then
               .Cells(lngC, 1).Interior.ColorIndex = 3    'Zelle Rot
               'wird die Zeile aus der Tabelle Rohdaten kopiert
               rngSuche.Offset(, 6).Resize(, 10).Copy
               'und in der Tabelle1 eingefügt
               .Cells(lngC, 7).PasteSpecial xlValues
            End If
         End If
      Next lngC
      Application.CutCopyMode = False
   End With
   Application.ScreenUpdating = True 'Bidschirmaktuallisierung ein
  
End Sub

[JimmyJoe]

fast, mit deinem Code werden die gefundenen Rot markiert, was aber bei den nicht gefundenen sein sollte

[atilla]

Hallo,

dann so:

Code:

Sub prcKopieren()
   Dim lngC As Long, lngZ As Long
   Dim rngSuche As Range
  
  Application.ScreenUpdating = False 'Bidschirmaktuallisierung aus
   With Worksheets("Tabelle1")
      lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row  'letzte belgte Zeile in Spalte A
      'eine Schleife durch die Spalte A der Tabelle1 bis zum Ende
      For lngC = 3 To lngZ
         If InStr(.Cells(lngC, 1), "Überschrift") = 0 Then   'wenn Zelle nicht "Überschrift"
            'der Wert aus der Zelle A... wird in der Tabelle Rohdaten gesucht
            Set rngSuche = Worksheets("Rohdaten").Columns(1).Find(.Cells(lngC, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
            'wenn der Wert in der Tabelle Rohdaten gefunden wird
            If Not rngSuche Is Nothing Then
               .Cells(lngC, 1).Interior.ColorIndex = xlNone 'wenn gefunden dann Zellfarbe raus
               'wird die Zeile aus der Tabelle Rohdaten kopiert
               rngSuche.Offset(, 6).Resize(, 10).Copy
               'und in der Tabelle1 eingefügt
               .Cells(lngC, 7).PasteSpecial xlValues
            Else
               .Cells(lngC, 1).Interior.ColorIndex = 3    'Zelle Rot
            End If
         End If
      Next lngC
      Application.CutCopyMode = False
   End With
   Application.ScreenUpdating = True 'Bidschirmaktuallisierung ein
  
End Sub

Die Zeilen mit Überschriften werden aussen vor gelassen.

[JimmyJoe]

Perfekt!!!!!!!!!!!!!!!!
vielen Dank an alle die mir geholfen haben :23:

[JimmyJoe]

Welche Voraussetzung muss die Zelle haben das sie als Überschrift erkannt wird?

[Steffl]

Hallo,

das hat Atilla im Code eingebaut ansonsten würde ich dir mal diese Seite empfehlen.

[atilla]

Hallo zusammen,

Stefan, da hab ich wohl zu oberflächlich gedacht.

In der Überschriftzelle wird wahrscheinlich etwas anderes stehen als "Überschrift.."

@JimmyJoe

Formatier die Überschriftzelle Fett, dann ersetze im Code diese Zeile:

Code:

If InStr(.Cells(lngC, 1), "Überschrift") = 0 Then   'wenn Zelle nicht "Überschrift"

mit dieser:

Code:

If .Cells(lngC, 1).Font.Bold = False Then    'wenn Zelle nicht Fett formatiert"