Gegevens uit 2 tabbladen combineren/extraheren

[jansm]

Wher, weer bedankt. Ik kijk vanavond naar het resultaat. Je hoort nog van me.
Snb, daar zeg je wat. De code begrijpt!!!! Het is een waarheid als een koe maar besef aub dat er mensen zijn die er echt blind voor zijn. En niet "oost-indisch" blind hoor.

 

[HSV]

De application.index is er debet aan dat onderstaande code ± 8x sneller is.

Sub hsv()
Dim sn, sp, arr
Dim i As Long, n As Long, j As Long, jj As Long
Dim Dic As Object
Dim id As String
Dim c As Range
Dim t As Single
t = Timer
 Set Dic = CreateObject("Scripting.Dictionary")
   sn = Sheets("personen").Cells(1).CurrentRegion
   sp = Sheets("feiten").Cells(1).CurrentRegion
      ReDim arr(1 To UBound(sn) + UBound(sp), 1 To UBound(sn, 2))
        For i = 1 To UBound(sn)
         id = sn(i, 1) & "_" & sn(i, 9)
         If Not Dic.Exists(id) Then
                 Dic(id) = 0
                  n = n + 1
              For j = 1 To UBound(arr, 2)
                arr(n, j) = sn(i, j)
              Next j
                    For jj = 2 To UBound(sp)
                      If sn(i, 1) = sp(jj, 1) Then
                        n = n + 1
                        arr(n, 5) = sp(jj, 19)
                      End If
                    Next jj
          End If
        Next i
   Sheets("Test").Cells(1).Resize(n, UBound(sn, 2)) = arr
 Debug.Print Format(Timer - t, "0.0000")
End Sub

 

[jansm]

HSV, WHER en Snb, bedankt. De code van HSV doet niet helemaal wat er gevraagd is. Hij pakt de 1e regel van de duplicaten terwijl de 2e gekopieerd moet worden. En er wordt geen rekening gehouden met de voorwaarde dat kolom R in [Feiten] de waarde ALIAS moet hebben.
De code van WHER en Snb doen er beide 4.5 minuut over om met het resultaat te komen voor 5300 regels. De code van HSV nu in 2 sec maar dat komt waarschijnlijk doordat deze 'het niet goed' doet.

 

[HSV]

Zo beter Jan?

Sub hsv()
Dim sn, sp, arr
Dim i As Long, n As Long, j As Long, jj As Long
Dim Dic As Object
Dim id As String
Dim c As Range
Dim t As Single
t = Timer
Application.ScreenUpdating = False
 Set Dic = CreateObject("Scripting.Dictionary")
   sn = Sheets("personen").Cells(1).CurrentRegion
   sp = Sheets("feiten").Cells(1).CurrentRegion
      ReDim arr(1 To UBound(sn) + UBound(sp), 1 To UBound(sn, 2))
        For i = 1 To UBound(sn)
         id = sn(i, 1) & "_" & sn(i, 9)
         If Not Dic.Exists(id) Then
                 Dic(id) = 0
                  n = n + 1
              For j = 1 To UBound(arr, 2)
                arr(n, j) = sn(i, j)
              Next j
                    For jj = UBound(sp) To 2 Step -1
                      If sn(i, 1) = sp(jj, 1) And sp(jj, 18) = "ALIAS" Then
                        n = n + 1
                        arr(n, 5) = sp(jj, 19)
                      End If
                    Next jj
          End If
        Next i
   Sheets("Test").Cells(1).Resize(n, UBound(sn, 2)) = arr
 Debug.Print Format(Timer - t, "0.0000")
End Sub

 

[jansm]

voorwaarde-probleem is opgelost, maar hij pakt nog steeds de eerste regel. De 2e regel moet naar tabblad 'Test'.

 

[HSV]

Ik kan hier vandaan alleen maar dezelfde gegevens constateren als @WHER.

 

[jansm]

wat bedoel je Harry?

 

[HSV]

Ik heb even van beiden een printje gemaakt in landscape.
Alleen de eerste twee pagina's geprint en vergelijken.

 

[jansm]

wilde je een bijlage meesturen? Ik begrijp niet wat je bedoelt?

 

[HSV]

Hierbij het bestand van @WHER incl. alle codes.

 

[jansm]

voor verschillen (Wher en HSV) kijk naar de kolommen M, N en P.
Als een persoon, ieder persoon heeft een uniek nummer, een partner heeft dan komt deze persoon in tabblad [Personen] 2 x voor: 1 x als persoon en 1x als partner. Je vindt deze persoon dan op 2 opvolgende rijen. Bijvoorbeeld op rij 1 en 2. Hiervan moet rij 2 naar [Test]. Persoonsnummer heeft 2 partners gehad en komt dus 4 keer voor (r15,16,17,18). Hiervan moet rij 16 en 18 over naar [Test]. Snapt?

 

[jansm]

Trouwens, heb jij wel eens moeten betalen?

 

[WHER]

@Harry,

Indien je kolom M en N van blad TEST vergelijkt (na jouw code en na "mijn" code), dan zie je het verschil waar jansm over spreekt (denk ik...)

edit; zie antwoord hierboven

 

[WHER]

Wat denken we van deze combinatie....

 

[HSV]

Daar kan rustig je eigen naam aan toegevoegd worden. :thumb:

 

[HSV]

Toch nog een methode die ± 10x sneller is (zie venster 'direct').
Ik hoop dat het resultaat overeenkomt anders houdt ik het maar voor gezien. :d

Edit: 20x was een vergelijking met de eerste, met je tweede inderdaad 10x.

 

[WHER]

Ik kom tot een verschil van 10 X sneller, hoe dan ook indrukwekkend, en de resultaten lijken overeen te komen.
Bij vorige versies was het snelheidsverschil vooral terug te voeren op de veelvuldige interactie met de worksheet (rijen invoegen enz...), dit keer lijkt enkel de Application.Index het verschil te maken.

 

[snb]

Een 'database' zet je toch bij voorkeur op met voor ieder record slechts 1 rij ?

Sub M_snb()
  sn = Sheets("Personen").Cells(1).CurrentRegion
  sp = Sheets("Feiten").Cells(1, 1).CurrentRegion
  
  With CreateObject("scripting.dictionary")
    For j = 1 To UBound(sn)
      .Item("It_" & sn(j, 1)) = Application.Index(sn, j)
    Next
    For j = 2 To UBound(sp)
       st = .Item("It_" & sp(j, 1))
       st(5) = st(5) & vbLf & sp(j, 19)
       .Item("It_" & sp(j, 1)) = st
    Next
    
    Sheets("Test").UsedRange.ClearContents
    Sheets("Test").Cells(2, 1).Resize(.Count, UBound(sn, 2)) = Application.Index(.Items, 0, 0)
  End With
End Sub

 

[jansm]

Hallo WHER en HSV, erg bedankt. Hij doet wat hij moet doen!! Maar hij is niet sneller dan "WHER" en "Snb" zoals HSV eerst dat. De codes doen er bij mij 4.5 minuten over om tot resultaat komen (5300 regels). Geen probleem want het is niet iets wat elke dag nodig is.
WHER/HSV, zou een van jullie achter de code willen vermelden welk deel van de code wat doet?

 

[HSV]

De snelheid nog iets weten op te voeren (alhoewel het fluctueert, misschien is het de moeite waard over die 5300 regels).

De lege elementen in de array worden nu buiten schot gehouden voor het inlezen in de tweede array.
Helaas heb ik geen zin om de code te voorzien van commentaar.
Ten eerste is het specifiek op maat gemaakt, en ten tweede gebruik je het maar sporadisch. :d