• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Waarde Verticaal ophalen VBA

Status
Niet open voor verdere reacties.
Is het snel genoeg?
Code: 
Sub hsv()
Dim sq, sn, sp, i As Long, ii As Long, j As Long
With Sheets("blad2")
 sq = Sheets("Blad1").Range("m5").CurrentRegion.Resize(, 4)
 sn = .Range("c2").CurrentRegion.Columns(1).Resize(, 4)
 sp = sn
  For i = 1 To UBound(sq)
    For ii = [COLOR="#FF0000"]1[/COLOR] To UBound(sn)
       If sq(i, 1) = sn(ii, 1) Then
         For j = 2 To 4
          sp(ii, j) = sq(i, j)
         Next j
       End If
     Next ii
    Next i
  .Range("M2").Resize(UBound(sn), 4) = sp
End With
End Sub
 
Laatst bewerkt:
Poeha das snel.......:)

En met een minimale verandering helemaal blij.


Code: 
Sub hsv()
Dim sq, sn, sp, i As Long, ii As Long, j As Long
With Sheets("blad2")
 sq = Sheets("Blad1").Range("m5").CurrentRegion.Resize(, 4)
 sn = .Range("c2").CurrentRegion.Columns(1).Resize(, 4)
 sp = sn
  For i = 1 To UBound(sq)
    For ii = i To UBound(sn)
       If sq(i, 1) = sn(ii, 1) Then
         For j = 2 To 4
          sp(ii, j) = sq(i, j)
         Next j
       End If
     Next ii
    Next i
  .Range("[COLOR="#FF0000"]C2[/COLOR]").Resize(UBound(sn), 4) = sp
End With
End Sub
:thumb:
 
Gerard,

Verander nog even onderstaande...
Code: 
 For ii =[COLOR=#ff0000] i [/COLOR]To UBound(sn)

....in.
Code: 
 For ii = [COLOR="#FF0000"]1[/COLOR] To UBound(sn)

Het is maar een fractie trager, maar voor ongesorteerde gegevens beter.
 
Heb nog een wijziging in de code aangebracht. Dit niet vanwege het feit dan het niet werkte maar omdat ik geen rekening heb gehouden dat in het origineel voorafgaand aan de kolom waar de gegevens in komen te staan ook gegevens stonden. De macro is nu als volgt;

Code: 
Sub hsv()
Dim sq, sn, sp, i As Long, ii As Long, j As Long
With Sheets("Rankingoverzicht")
 sq = Sheets("Blad1").Range("m14").CurrentRegion.Resize(, 4)
 [COLOR="#FF0000"]sn = Range("C6:F" & Range("C1500").End(xlUp).Row) [/COLOR]
 sp = sn
  For i = 1 To UBound(sq)
    For ii = 1 To UBound(sn)
       If sq(i, 1) = sn(ii, 1) Then
         For j = 1 To 4
          sp(ii, j) = sq(i, j)
         Next j
       End If
     Next ii
    Next i
  .Range("C6").Resize(UBound(sn), 4) = sp
End With
End Sub

Groet Geer
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan