Prijslijsten samenvoegen met behouden van sommige kolommen

[jvanro]

Beste,

Ik zou 2 prijslijsten moeten samenvoegen (van 9000 en 11000 rijen).
Heb ze al onder elkaar in één excel file gezet en dan gesorteerd.

Hierbij zouden dezelfde artikels op één regel moeten gezet worden maar met de prijs van beide leveranciers naast elkaar.
De beschrijving van de artikels is van minder belang, dit mag willekeurig van één van de twee leveranciers zijn, of steeds van dezelfde leverancier, ...

In bijlage een voorbeeldje van de prijslijst met daarbij ook wat het zou moeten worden (in deze excel manueel gedaan voor enkele rijen)

Iemand raad?

Hartelijk dank,
JonasBekijk bijlage Voorbeeld excel.xlsx

 

[Gerard2348]

Heb deze opgenomen met de macrorecorder. Heb gebruik gemaakt van de functie samenvoegen. Kan zeker beter.
Misschien werkt dit voor jou.

Bekijk bijlage Voorbeeld excel1a.xlsm

Groet

 

[pasan]

Dit is wat ik ervan gebrouwen heb
De eerste regel "Option Base 1" staat helemaal bovenin de module

Option Base 1
Sub unieke_Artikel()
With Sheets("Blad1")
 a_sn_Artikel = .Cells(1, 1).CurrentRegion
 b_sn = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Value

  With CreateObject("scripting.dictionary")
    For Each cl In b_sn
     If cl <> "" And Not .Exists(cl) Then .Add cl, Nothing
    Next
   lijst = .Keys
  End With
 
  ReDim k(UBound(lijst), UBound(a_sn_Artikel, 2))

  For jj = 2 To UBound(a_sn_Artikel)
   If a_sn_Artikel(jj, 3) <> "" Then c00 = c00 & "_" & jj
   If a_sn_Artikel(jj, 4) <> "" Then c01 = c01 & "_" & jj
  Next
  
    lijst1 = Application.Index(a_sn_Artikel, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1, 2, 3, 4))
    lijst2 = Application.Index(a_sn_Artikel, Application.Transpose(Split(Mid(c01, 2), "_")), Array(1, 2, 3, 4))
    Uniek1 = WorksheetFunction.Transpose(Application.Index(a_sn_Artikel, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1)))
    Uniek2 = WorksheetFunction.Transpose(Application.Index(a_sn_Artikel, Application.Transpose(Split(Mid(c01, 2), "_")), Array(1)))
   
    For i = 1 To UBound(Uniek1)
      If Not IsError(Application.Match(Uniek1(i), [Uniek2], 0)) Then
      lijst1(i, 4) = lijst2(i, 4)
      End If
    Next i
     
    For i = 1 To UBound(lijst1, 1)
     For j = 1 To UBound(lijst1, 2)
      k(i, j) = lijst1(i, j)
     Next j
    Next i
    
       For ii = 1 To UBound(lijst2, 1)
        For jj = 1 To UBound(lijst2, 2)
         If IsError(Application.Match(Uniek2(ii), [Uniek1], 0)) Then
           k(i, jj) = lijst2(ii, jj)
          If jj = UBound(lijst2, 2) Then i = i + 1
         End If
        Next jj
       Next ii
       
 .Cells(2, 8).Resize(UBound(k, 1), UBound(k, 2)).ClearContents
 .Cells(2, 8).Resize(UBound(k, 1), UBound(k, 2)) = k
End With
End Sub

 

[jvanro]

Dit is wat ik ervan gebrouwen heb
De eerste regel "Option Base 1" staat helemaal bovenin de module

Option Base 1
Sub unieke_Artikel()
With Sheets("Blad1")
 a_sn_Artikel = .Cells(1, 1).CurrentRegion
 b_sn = .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp)).Value

  With CreateObject("scripting.dictionary")
    For Each cl In b_sn
     If cl <> "" And Not .Exists(cl) Then .Add cl, Nothing
    Next
   lijst = .Keys
  End With
 
  ReDim k(UBound(lijst), UBound(a_sn_Artikel, 2))

  For jj = 2 To UBound(a_sn_Artikel)
   If a_sn_Artikel(jj, 3) <> "" Then c00 = c00 & "_" & jj
   If a_sn_Artikel(jj, 4) <> "" Then c01 = c01 & "_" & jj
  Next
  
    lijst1 = Application.Index(a_sn_Artikel, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1, 2, 3, 4))
    lijst2 = Application.Index(a_sn_Artikel, Application.Transpose(Split(Mid(c01, 2), "_")), Array(1, 2, 3, 4))
    Uniek1 = WorksheetFunction.Transpose(Application.Index(a_sn_Artikel, Application.Transpose(Split(Mid(c00, 2), "_")), Array(1)))
    Uniek2 = WorksheetFunction.Transpose(Application.Index(a_sn_Artikel, Application.Transpose(Split(Mid(c01, 2), "_")), Array(1)))
   
    For i = 1 To UBound(Uniek1)
      If Not IsError(Application.Match(Uniek1(i), [Uniek2], 0)) Then
      lijst1(i, 4) = lijst2(i, 4)
      End If
    Next i
     
    For i = 1 To UBound(lijst1, 1)
     For j = 1 To UBound(lijst1, 2)
      k(i, j) = lijst1(i, j)
     Next j
    Next i
    
       For ii = 1 To UBound(lijst2, 1)
        For jj = 1 To UBound(lijst2, 2)
         If IsError(Application.Match(Uniek2(ii), [Uniek1], 0)) Then
           k(i, jj) = lijst2(ii, jj)
          If jj = UBound(lijst2, 2) Then i = i + 1
         End If
        Next jj
       Next ii
       
 .Cells(2, 8).Resize(UBound(k, 1), UBound(k, 2)).ClearContents
 .Cells(2, 8).Resize(UBound(k, 1), UBound(k, 2)) = k
End With
End Sub

En hoe pas ik dit nu toe op mijn excel file? Ben nog niet zo mee met modules, na wat opzoekwerk geraak ik er niet direct wijzer uit..

 

[pasan]

hier een voorbeeld bestand