aanvullen van rijen met data uit kolom (ander werkblad)

[flupje]

Beste,

Ik ben op zoek naar passende VBA-code om data in rijen op het eerste werkblad te vergelijken data uit kolommen op het tweede werkblad. Indien De datareeks nog niet voorkomt op het eerste werkblad, moet de reeks gekopieerd worden naar dit werkbblad.

Het tweede werkblad wordt immers gebruikt om data te halen uit een systeem, die we dan verder willen analyseren op het eerste werkblad

Alvast bedankt

Bekijk bijlage voorbeeld.xlsx

 

[Wigi]

Zie bijlage.

Wigi

 

[flupje]

Beste Wigi,

Gegevens worden inderdaad gekopieerd van het tweede naar het eerste werkblad, maar hij controleert blijkbaar niet of deze reeds op het eerste werkblad aanwezig zijn. Het is de bedoeling dat enkel de gegeven gekopieerd worden die nog niet aanwezig zijn.

Toch reeds bedankt
Flip

 

[RaymondC]

Heb onderstaande code ooit een gevonden op het www, maar weet de auteur ervan niet meer.

Option Explicit
Sub verschil()
  Dim gebied1 As Range, gebied2 As Range, isect As Range, zoekklient As Range, referentieblad, blad, c, firstaddress As String
  Dim lrij As Long, T As Boolean, r As Long, k As Integer, Rmax As Long, Kmax As Integer, r2 As Long, R2max As Integer, functie As String

  Sheets("verschillen").Range("A2:G1000").ClearContents    'in blad 3 kolom A gevonden verschillen wegschrijven
  lrij = 2
  For referentieblad = 1 To Sheets.Count
    Sheets(referentieblad).Activate
    If Sheets(referentieblad).Name <> "verschillen" Then
      Set gebied1 = Cells(1, 1).CurrentRegion
      Rmax = gebied1.Rows.Count
      Kmax = gebied1.Columns.Count
      For blad = 1 To Sheets.Count
        If Sheets(blad).Name <> "verschillen" And Sheets(blad).Name <> Sheets(referentieblad).Name Then
          Set gebied2 = Sheets(blad).Cells(1, 1).CurrentRegion  'bepaal het gebied daar om dubbels te vermijden
          R2max = gebied2.Rows.Count
          For r = 2 To Rmax                                '1e rij = hoofding
            T = False
            If referentieblad > blad Then
              Set isect = Intersect(Sheets(blad).Cells(r, 1), gebied2)
              T = Not (isect Is Nothing)                   'de intersectie is niet leeg, we hebben deze cel al vroeger bekeken
            End If
            r2 = 0
            With Sheets(blad).Range("A1:A" & R2max)        '(Cells(1, 1), Cells(R2max, 1))
              Set c = .Find(Cells(r, 1), LookIn:=xlValues, lookat:=xlWhole)
              If Not c Is Nothing Then
                firstaddress = c.Address
                Do
                  If Cells(r, 23) = Sheets(blad).Cells(c.Row, 23) Then
                    r2 = c.Row
                  Else
                    Set c = .FindNext(c)
                  End If
                Loop While Not c Is Nothing And c.Address <> firstaddress And r2 = 0
              End If
            End With

            If r2 = 0 Then
              Sheets("verschillen").Cells(lrij, 1) = Cells(r, 1).Value
              Sheets("verschillen").Cells(lrij, 2) = Cells(r, 2).Value
              Sheets("verschillen").Cells(lrij, 3) = Cells(r, 23).Value
              Sheets("verschillen").Cells(lrij, 4) = Sheets(referentieblad).Name & " " & Cells(r, 1).Address
              Sheets("verschillen").Cells(lrij, 5) = Sheets(blad).Name & " " & "onvindbaar"
              lrij = lrij + 1
            End If

            If Not T And r2 <> 0 Then
              For k = 2 To Kmax
                If Cells(r, k).Value <> Sheets(blad).Cells(r2, k).Value Then
                  Sheets("verschillen").Cells(lrij, 1) = Cells(r, 1).Value
                  Sheets("verschillen").Cells(lrij, 2) = Cells(r, 2).Value
                  Sheets("verschillen").Cells(lrij, 3) = Cells(r, 23).Value
                  Sheets("verschillen").Cells(lrij, 4) = Sheets(referentieblad).Name & " " & Cells(r, k).Address
                  Sheets("verschillen").Cells(lrij, 5) = Sheets(blad).Name & " " & Cells(r2, k).Address
                  Sheets("verschillen").Cells(lrij, 6) = Sheets(referentieblad).Cells(r, k).Value
                  Sheets("verschillen").Cells(lrij, 7) = Sheets(blad).Cells(r2, k).Value
                  lrij = lrij + 1
                  'MsgBox "bart"
                End If
              Next
            End If
          Next
        End If
      Next
    End If
  Next
  Sheets("verschillen").Activate
End Sub