Macro die data ophaalt van ander blad

[swanwil]

Hallo,
Ik ben op zoek naar een macro die hetzelfde doet als de formules die nu in kolom E en F staan, zodat er meteen waarden staan i.p.v. Formules
De data wordt opgehaald uit een tabel
Zou ik deze data ook op kunnen halen met een macro per tabblad en eventueel ook over alle tabbladen (behalve tabblad data)?
Zou dit ook kunnen als de tabel in een ander document staat?

 

[swanwil]

Sub data_ophalen()

Dim S As Range
Set S = Selection
Dim A As Range, Zoek As Range

    Set A = ActiveSheet.Range("D2")
    
    Sheets("data").Select
    
    Do Until IsEmpty(A)
    
        Set Zoek = Columns(1).Find(A.Value)
        
        If Zoek Is Nothing Then
        
            A.ActiveCell.Value = ""
                
                Else
        
            A.Offset(0, 1).Value = Zoek.Offset(0, 1).Value
            A.Offset(0, 2).Value = Zoek.Offset(0, 2).Value
            A.Offset(0, 3).Value = Zoek.Offset(0, 3).Value
        
        End If
    
        Set A = A.Offset(1, 0)
    Loop


    S.Parent.Activate
    S.Select 'Not Activate - possibly more than one cell!

End Sub

Ik ben zelf al aan t knutselen geweest en krijg een beetje data opgehaald.
Omschrijving NL en UK krijg ik niet in 1 cel zoals de formule
Als er een lege regel is stopt de macro
Hij pakt maar 1 tabblad.

Kan iemand me helpen?

 

[JEC.]

Twee varianten. De tweede vind ik persoonlijk mooier.
Met de tabel in een ander bestand kan het uiteraard ook.

Sub jec()
 Dim sh, ar, xp, a
 ar = Sheets("data").ListObjects(1).DataBodyRange
 For Each sh In Sheets
   If sh.Name <> "data" Then
     xp = sh.Range("D2", sh.Range("D" & Rows.Count).End(xlUp))
     With Application
       a = .IfError(.Index(ar, .Match(.Index(xp, , 1), .Index(ar, , 1), 0), Array(2, 3, 4)), "")
       For i = 1 To UBound(a)
         a(i, 1) = a(i, 1) & vbLf & a(i, 2)
         a(i, 2) = a(i, 3)
       Next
       sh.Range("E2").Resize(UBound(a), UBound(a, 2) - 1) = a
     End With
   End If
 Next
End Sub

Sub jecc()
 Dim dic, ar, sh, xp
 Dim i As Long, j As Long
 
 Set dic = CreateObject("scripting.dictionary")
 ar = Sheets("data").ListObjects(1).DataBodyRange
 
 For i = 1 To UBound(ar)
   dic(ar(i, 1)) = Array(ar(i, 2) & vbLf & ar(i, 3), ar(i, 4))
 Next
 For Each sh In Sheets
   If sh.Name <> "data" Then
     xp = sh.Range("D2", sh.Range("D" & Rows.Count).End(xlUp)).Resize(, 3)
     For j = 1 To UBound(xp)
       If dic.exists(xp(j, 1)) Then
         xp(j, 2) = dic(xp(j, 1))(0)
         xp(j, 3) = dic(xp(j, 1))(1)
       End If
     Next
    sh.Range("D2").Resize(UBound(xp), UBound(xp, 2)) = xp
   End If
 Next
End Sub

 

[swanwil]

@jec,

Top! Dankjewel, ik ga er mee aan de slag

Gr swanwil

 

[swanwil]

@ jec
Ik begrijp niet precies hoe je macro werkt, maar ik wil nog 2 kolommen toevoegen aan het datablad en de data plaatsen in kolommen F, O, P en Q maar krijg het niet voor elkaar
Hoe kan ik dit het beste doen?

Gr. swanwil

 

[snb]

Dan lijkt het me beter de gegevens van alle tabbladen, behalve 'data", in 1 werkblad te zetten.

 

[swanwil]

@snb
Het is voor een stuklijst bedoeld die gemiddeld zo'n 15 tabbladen heeft, met een centraal voorblad en vervolgens per hoofddeel een apart tabblad.
Behalve artikelnummer waarvan data opgehaald wordt zijn de andere kolommen gevuld met aanvullende tekst en opmerkingen

 

[swanwil]

Datablad heeft dus 6 kolommen A t/m F
En de diverse tabbladen hebben in kolom D het artikelnummer
In kolom F komt dan Omschrijving NL en UK
In kolom O de stuksprijs
In kolom P het gewicht
In kolom Q de status

 

[snb]

Dat begreep iik al.
Er is geen enkele reden de gegevens van hoofddelen in aparte werkbladen onder te brengen: zet ze allemaal in 1 werkblad.
Hoe eenvoudiger de struktuur, hoe simpeler formules en/of code met gelijkblijvende functionaliteit.

 

[swanwil]

@ snb
Ik begrijp je punt maar krijg ik niet veranderd. Heeft ook met opbouwen van het product te maken
Kan het wel dat het in het actieve tabblad werkend krijg, zoals ik aangaf?