Zoeken met index en verschuiving

[excelyeshead]

Hallo VeA,

Ja het gaat om de code in #16. Krijg deze niet werkend in het nieuwe bestand die ik heb ge upload.

Omdat ik hier werk met meerdere tabbladen en kolommen werkt deze formule alleen maar voor de eerste kolom (Blad 2)

Graag zie ik deze formule werkend voor heel Blad2.

Ik hoop dat je dit werkend kan krijgen!

Groeten,

Martin

 

[excelyeshead]

Ik ben bang dat ik dit dus niet beantwoord krijg

 

[HSV]

Het eerste resultaat in blad3, en het eindresultaat in blad4.

Het kan ook rechtstreeks in blad3, maar eerst maar als overzicht of het zo klopt.

 

[excelyeshead]

Hallo Harry,

Bedankt voor je moeite om dit werkend te krijgen. Alleen krijg ik een foutmelding bij het openen van dit bestand. Ik zie dat het een "XLSB" bestand is geworden. Misschien heeft het daarmee te maken?

Ik hoor graag van je wat de oplossing is.

Groeten,

Martin

 

[Haije]

Alleen krijg ik een foutmelding bij het openen van dit bestand

welke?

 

[excelyeshead]

Hallo Haije,

Het gaat om deze foutmelding:

"Er zijn problemen aangetroffen met bepaalde inhoud in Index met verschuiven V03.xlsb. Wilt u de inhoud zo ver mogelijk herstellen? Klik op Ja als u de bron van deze werkmap vertrouwt

Als ik op Ja klik gaat Excel wel verder maar ik krijg geen data te zien.

Kan je me hier mee helpen?

Groeten
Martin

 

[VenA]

Gewoon op ja klikken en de macro starten.

 

[excelyeshead]

Hallo helpers,

Ik krijg daarna deze foutmelding (zie attachment) dan te zien en ik krijg op blad 3 hetzelfde resultaat te zien als Blad1 en op Blad 4 krijg ik niets te zien.

Ik zou graag het resultaat van Blad2 willen zien in de formule (of Macro)



Groeten

Martin

 

[VenA]

Dat krijg je ook.

 

[excelyeshead]

Beste VenA,

Geweldig! Het werkt en alvast bedankt voor je inzet. Misschien nog 1 vraag. Ik zie dat je op blad 3 eigenlijk dezelfde waardes creëert die ik in Blad1 met een formule probeer te maken. Kan je ook zonder Blad1 Blad4 maken?
Kijk maar of dit lukt, ik ben al zeer tevreden met het eindresultaat tot nu toe.

Bedankt allemaal ook voor het helpen.

Groeten Martin

 

[VenA]

Zonder wegschrijven kan ook je zal dan verder moeten gaan met array a.
Het wordt dan zoiets.

Sub hsvvena()
Dim sv, sv2, i As Long, ii As Long, j As Long, n As Long
With Sheets("artikelen")
 sv = Sheets("blad1").Cells(5, 1).Resize(, 6)
 sv2 = .ListObjects(1).DataBodyRange
 ReDim a(UBound(sv2), 5)
  For j = 2 To UBound(sv, 2)
   If j <> 3 Then
    For i = 1 To UBound(sv2)
      If sv2(i, 3) = sv(1, j) Then
       a(n, 0) = "Hoofdartikel"
       a(n, j - 1) = sv2(i, 1)
       n = n + 1
      End If
    Next i
   End If
   n = 0
  Next j
 'Sheets("blad3").Cells(1).Resize(UBound(sv2), 6) = a
 End With
 'Erase a
 'With Sheets("blad3")
  'sv = .Cells(1, 2).CurrentRegion.Resize(, 6)
  ReDim b(UBound(sv2), 5)
  For j = 2 To 6 Step 4
      For i = 1 To UBound(a)
        b(i - 1, 4) = a(i - 1, 4)
        For ii = 1 To UBound(sv2)
          If sv2(ii, 3) = a(i - 1, j - 1) Then
            b(n, 0) = "Hoofdartikel:"
            b(n, IIf(j = 2, j - 1, 5)) = sv2(ii, 1)
           n = n + 1
          End If
        Next ii
      Next i
      n = 0
    Next j
  'End With
 Sheets("blad4").Cells(1).Resize(UBound(a), 6) = b
End Sub

 

[HSV]

Gang is alles.

Sub hsvvena()
Dim sv, sv2, b, i As Long, ii As Long, j As Long, n As Long, x As Long
With Sheets("artikelen")
 sv = Sheets("blad1").Cells(5, 1).Resize(, 6)
 sv2 = .ListObjects(1).DataBodyRange
 ReDim a(UBound(sv2), 5)
  For j = 2 To UBound(sv, 2)
   If j <> 3 Then
    For i = 1 To UBound(sv2)
      If sv2(i, 3) = sv(1, j) Then
         a(n, j - 1) = sv2(i, 1)
         n = n + 1
      End If
    Next i
   End If
   If x < n Then x = n
   n = 0
  Next j
 End With
  b = a
  For j = 2 To 6 Step 4
      For i = 1 To x
        For ii = 1 To UBound(sv2)
          If sv2(ii, 3) = a(i - 1, j - 1) Then
            b(n, 0) = "Hoofdartikel:"
            b(n, IIf(j = 2, j - 1, 5)) = sv2(ii, 1)
           n = n + 1
          End If
        Next ii
      Next i
      n = 0
    Next j
  Sheets("blad4").Cells(1).Resize(UBound(a), 6) = b
End Sub

 

[excelyeshead]

Beste Harry en VenA,

Bedankt voor jullie reactie. Ik heb de macro's toegepast en ik met mijn kennis dacht wel even deze code te kunnen aanpassen en voor meerdere kolommen te laten bereken. Toch kom ik er niet uit en misschien kunnen jullie nog een keer hier naar kijken? Het is dus de bedoeling dat ik artikelnummers in Blad1 "plak" en de formule die eronder staat rekent dan de doosnummers uit. Deze doosnummers worden voor meerdere samengestelde hoofdartikelen gebruikt. Dus wil graag weten in bij welke hoofdartikelen deze dozen allemaal voorkomen. Dit resultaat zou ik dus graag zien op Blad!4.
Met de hierboven gemaakte Macro's komen we al een heel eind maar het laatste stukje ontbreekt er nog net voor mij.

Ik hoop dat jullie nog een keertje hiernaar kunnen kijken.

Alvast enorm bedankt voor de energie die

 

[HSV]

Ik pas, geen zin om het tig keer over te doen.
Vast wel iemand die het wil overnemen.

 

[VenA]

Wat heb je zoal geprobeerd dan? De laatste code staat niet eens in het bestand.
Met oa <F8> kan je code debuggen. Je kan dan zien welke variabele op welk moment welke waarde krijgt. Code wordt altijd gemaakt obv een voorbeeldbestand. Als dit bestand steeds wijzigt dan zal je het zelf aan moeten passen.

In het rood gedeeltes waar je denk ik naar moet kijken/aanpassen.

Sub hsvvena()
Dim sv, sv2, b, i As Long, ii As Long, j As Long, n As Long, x As Long
With Sheets("artikelen")
 sv = Sheets("blad1").Cells(5, 1).[COLOR="#FF0000"]Resize(, 6)[/COLOR]
 sv2 = .ListObjects(1).DataBodyRange
 ReDim a(UBound(sv2), [COLOR="#FF0000"]5[/COLOR])
  For j = 2 To UBound(sv, 2)
  [COLOR="#FF0000"] If j <> 3 Then[/COLOR]
    For i = 1 To UBound(sv2)
      If sv2(i, 3) = sv(1, j) Then
         a(n, j - 1) = sv2(i, 1)
         n = n + 1
      End If
    Next i
   [COLOR="#FF0000"]End If[/COLOR]
   If x < n Then x = n
   n = 0
  Next j
 End With
  b = a
  [COLOR="#FF0000"]For j = 2 To 6 Step 4[/COLOR]
      For i = 1 To x
        For ii = 1 To UBound(sv2)
          If sv2(ii, 3) = a(i - 1, j - 1) Then
            b(n, 0) = "Hoofdartikel:"
            b(n,[COLOR="#FF0000"] IIf(j = 2, j - 1, 5)[/COLOR]) = sv2(ii, 1)
           n = n + 1
          End If
        Next ii
      Next i
      n = 0
    Next j
  Sheets("blad4").Cells(1).Resize(UBound(a),[COLOR="#FF0000"] 6[/COLOR]) = b
End Sub