Frage von molekuelx, 61

VBA: Suche in Arbeitsmappe 2 bestimmte Zeile (und Zelle), kopiere sie und füge die Zelle in Arbeitsmappe 1 in gleiche Zeile ein?

Hallo Zusammen,

vielen Dank nochmal für die Hilfe bei meinem letzen Problem!!!

Jetzt habe ich ein neues Problem was mit einem Marko zu lösen wäre:

Ich möchte dass mir Excel in Arbeitsmappe 2 den Bereich D2:H150 durchsucht und mit dem Bereich C6:G150 in Arbeitsmappe 1 vergleicht.

Stimmen fünf bestimmten aufeinanderfolgende Zellen einer Zeile (z.B. D2, E2, F2, G2 und H2) in Arbeitsmappe 2 mit den fünf bestimmten Zellen einer Zeile (C6,D6,E6,F6 und G6) in Arbeitsmappe 1 überein, dann kopiere aus Arbeitsmappe 2 die Zelle AN2 und füge sie in Arbeitsmappe 1 in Zelle R6 ein.

Ausgelöst soll dies werden, wenn die Arbeitsmappe 2 neu gefüllt wird.

Das Makro soll den gesammten Bereich wie oben genannt überprüfen und gleichermaßen vorgehen. Wenn in Arbeitsmappe 2 die Zelle D2 leer ist oder in Arbeitsmappe 1 die Zelle C1 leer ist, soll nichts passieren (auch keine "fehlermeldung")

Findet das Makro jedoch nicht alle Zeilen der Arbeitsmappe 2 in der Arbeitsmappe 1, soll z.B das Feld D2 dieser nicht auffinbaren Zeile in der Arbeitsmappe 1 farblich markiert werden. Ebeneso für AMap.1 --> Gibt es Zeilen in dem Bereich in Arbeitsmappe 1 die er nicht in Arbeitsmappe 2 findet, sollen z.B. die Zelle C6 dieser Zeile farblich markiert werden.

Sub test() 
Dim Anzahl As Long, A As Long 
Dim SZelle As Range 
Dim Suchwert As String 
 
Suchwert = "Haus" 'Suchbegriff 
 
Anzahl = Application.WorksheetFunction.CountIf(Tabelle1.Range("A:A"), Suchwert) 
 
For A = 1 To Anzahl 
 If A = 1 Then 
  Set SZelle = Tabelle1.Range("A:A").Find(Suchwert) 
  Rows(SZelle.Row).Copy Tabelle2.Cells(A, 1) 'ganze Zeile Kopieren 
 Else 
  Set SZelle = Tabelle1.Range("A:A").FindNext(SZelle) 
  Rows(SZelle.Row).Copy Tabelle2.Cells(A, 1) 'ganze Zeile Kopieren 
 End If 
Next A 
 
End Sub

Das wäre ein erster Ansatz, nur er soll nicht ein bestimmten Suchbegriff suchen, sondern die 5 genannten Zellen einer Zeile vergleichen und dann nicht die ganze Zeile kopieren sondern nur eine Zelle (bzw. erweiterbar für beliebig viele Zellen).

Vielen dank für eure Unterstützung! Tolle Community hier bei gf!!!

Antwort
von beroud, 39

das makro wäre jetzt nicht das Problem, aber ich habe noch verständnisprobleme

zum einen sind die Bereiche verschieden groß - sheet1 = 149 zeilen - sheet2 = 145 zeilen

alle zellen identisch --> sheets1.r6 = sheet2.an2

inhalt zelle sheet1 nicht identisch zu inhalt zelle sheet2 - werden beide zellen markiert?

inhalt zelle sheet1 leer und inhalt zelle sheet2 gefüllt - werden beide zellen markiert, oder keine oder nur eine von beiden? welche?

inhalt zelle sheet1 gefüllt und inhalt zelle sheet2 leer- werden beide zellen markiert, oder keine oder nur eine von beiden? welche?

sollen zellen oder zeilen markiert werden?

Kommentar von molekuelx ,

Ja die Bereiche sind unterschiedlich groß...man kann sie aber auch gleich groß machen ... die Zellen sind eigentlich ab Zeile 135 alle leer ... es soll aber ein puffer gelassen werden falls Zeilen dazukommen (daher sollen leere Zeilen ignoriert werden)

die zellen R6:R150 und AN2:AN150 haben eigentlich die selben inhalte ... nur nicht wenn sich in sheet2 etwas ändert (aber gleich formatiert)

inhalte in sheet 1 nicht zu finden in sheet 2 dann nur in sheet 1 die jeweilige zelle in spalte C markieren ---> excel findet in sheet 2 im Bereich D2:H150 die Zellen C6:G6 nicht dann markiere C6 (gleiches umgekehrt für sheet 2

Es geht darum, dass die reihenfolge der Zeilen nicht zwangsläuftig in beiden sheets identisch ist. sobald er sich sicher sit dass z.B. C20:G20 in sheet1 mit D40:H40 überseinstimmt (also C20 = D40, D20 = E40, usw.) dann kopiere aus sheet 2 die Zelle AN40 und überschreibe damit die Zelle R20 in sheet 1

Ersetzt soll abe nur von sheet 2 in sheet 1 werden ... jedoch überprüft ob welche nicht in beiden vorhanden sind, sollen beide sheets

hoffe es ist verständlich :P 


 

Kommentar von beroud ,

arbeitsmappe

Sub vergleich()
   For sp = 0 To 4
      sp1 = 4 + sp
      sp2 = 3 + sp
      For ze = 0 To 148
         ze1 = 9 + ze
         ze2 = 2 + ze
        
         v1 = Sheets(1).Cells(ze1, sp1)
         v2 = Sheets(2).Cells(ze2, sp2)
        
         c1 = True
         c2 = True
     
         If (v1 = v2) Then
            c1 = False
            c2 = False
         End If
     
         If (v1 = "") Then
            c1 = False
         End If
        
         If (v2 = "") Then
            c2 = False
         End If
        
         If (c1 = True) Then
            Sheets(1).Cells(ze1, sp1).Interior.Color = RGB(255, 255, 0)
         Else
            Sheets(1).Cells(ze1, sp1).Interior.Color = xlNone
         End If

         If (c2 = True) Then
            Sheets(2).Cells(ze2, sp2).Interior.Color = RGB(255, 255, 0)
         Else
            Sheets(2).Cells(ze2, sp2).Interior.Color = xlNone
         End If
               
      Next
   Next
End Sub

tabelle1 und tabelle2

Sub Worksheet_Change(ByVal Target As Range)
   Call DieseArbeitsmappe.vergleich
End Sub

Kommentar von molekuelx ,

Danke schonmal für deine Mühe. Habe den Code eingefügt aber es kommt ein Fehler:

Laufzeitfehler '40036'

Anwendungs- oder objektdefinierter Fehler

... Muss ich in den Code noch den Namen der Arbeitsmappen integrieren? Diese heißen nähmlich nicht sheet1 und sheet2 sondern jeweills anders.

Fürt dieses Makro auch den Kopiervorgang von "sheet2" in "sheet1" durch oder fährt dieser nur rein den Vergleich der beiden Mappen?

Danke !!!

Kommentar von beroud ,

Sub vergleich()
   Application.EnableEvents = False
   Application.ScreenUpdating = False
 
   gl = True
  
   For sp = 0 To 4
      sp1 = 4 + sp
      sp2 = 3 + sp
      For ze = 0 To 148
         ze1 = 9 + ze
         ze2 = 2 + ze
        
         v1 = Sheets(1).Cells(ze1, sp1)
         v2 = Sheets(2).Cells(ze2, sp2)
        
         c1 = True
         c2 = True
     
         If (v1 = v2) Then
            c1 = False
            c2 = False
         End If
     
         If (v1 = "") Then
            c1 = False
         End If
        
         If (v2 = "") Then
            c2 = False
         End If
        
         If (c1 = True) Then
            gl = False
            Sheets(1).Cells(ze1, sp1).Interior.Color = RGB(255, 255, 0)
         Else
            Sheets(1).Cells(ze1, sp1).Interior.Color = xlNone
         End If

         If (c2 = True) Then
            gl = False
            Sheets(2).Cells(ze2, sp2).Interior.Color = RGB(255, 255, 0)
         Else
            Sheets(2).Cells(ze2, sp2).Interior.Color = xlNone
         End If
              
      Next
   Next

   If gl = True Then Sheets(1).Cells(20, 18) = Sheets(2).Cells(40, 40) Else Sheets(1).Cells(20, 18) = ""
  
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

das umkopieren ist jetzt drin - die Events sind während der Prüfung abgeschaltet, damit sich das makro nicht mehr selbst aufruft - "Sheets(1)" ist zugriff ohne namen

den fehler habe ich nicht, in manchen foren wird aber auf "schlechte tabellennamen hingewiesen, also mit Leerzeichen - da vba die Tabellen mit namen indentifiziert, ist das wohl bei makros ein Problem - hatte ich aber auch schon in der stundenerfassung - da mußten auch die Leerzeichen alle raus

Kommentar von molekuelx ,

sry dass ich erst so spät antworte:

Jetzt kommt kein Fehler mehr, aber:

- er Markiert jedesmal in sheet 1 den bereich D9:G:136 gelb, obwohl die Felder mit denen in sheet 2 im bereich D5:H132 übereinstimmen. (C6:G8 werden in sheet 1 richtigerweise nicht markiert)

- da er die drei zeilen 6,7 und 8  in sheet 1 richtigerweise nicht markiert hat, hätte er ja z.B. AN2 in R6 kopieren müssen. Das ist aber nicht passiert.

Vielleicht macht es das Einfärben zu kompliziert und man sollte das makro erstmal auf die Hauptfunktion eingrenzen:

1. Vergleiche immer Text in sheet 1 Spalte C mit dem in sheet 2 Spalte D

2. Vergleiche Wert in sheet 1 Spalte D mit dem in sheet 2 Spalte E

... Das wiederhole für den ganzen bereich sheet 1(C6:G136) bzw. sheet 2 (D2:H132)

3. Wenn du dir sicher bist, dass du eine Zeile in sheet 2 gefunden hast die einer zeile in sheet 1 übereinstimmt (sprich sheet 1 C100 gleicher text wie sheet 2 D33 + sheet 1 D100 gleicher wert wie sheet 2 E33, usw.  [ímmer eins verstetzt bis] sheet 1 G100 gleicher wert wie sheet 2 H33

, dann  kopiere in diesem Beispiel von sheet 2 den wert in sheet 2 Zelle AN33 und überschreib den Wert in sheet 1 Zelle R100 !!!

4. Es geht quasi um einen ablgleich zweier Teilelisten ... jedes Teil hat eine Zeile und in den Spalten sind spezifische Werte eingetragen wobei die zu vergleichende Spalten jeweils den Teilenamen / bzw. Teile nummer beinhalten.

5. Wenn sich das Makro sicher ist, das richtige Teil gefunden zu haben soll er aus dem neueren Stand in sheet 2 einen speziellen Wert (in dem Fall den in Spalte AN) in die Spalte R in sheet 1 überschreiben

6. Das mit der Farbliche Einfärbung wäre nur das Pünktchen auf dem i ... um sicher zu gehen dass alle Teile von sheet 1 auch in sheet 2 gefunden wurden bzw. ob mehr teile in sheet 2 enthalten sind als in sheet 1

--> Ich denke mein Problem ist etwas abstrakt und schwer zu erklären ... leider bin ich gerade erst dabei VBA besser zu lernen ...

 

Ich bin für jede Hilfe dankbar!

Keine passende Antwort gefunden?

Fragen Sie die Community