Hulp nodig voor code

Status
Niet open voor verdere reacties.
L

LDW

Nieuwe gebruiker
Lid geworden
7 dec 2017
Berichten
2
Dag allemaal,
Ik zou graag automatische code schrijven (in VBA) dat indien de waarde uit kolom A van tabblad "1" overeen komt met kolom A van tabblad "2" dan moeten de waarden uit de kolommen B, C en D (tabblad 2) van die rij gekopieerd worden naar het tabblad 1. De excel is uitgedunde versie, maar als het hier werk zal het voor mijn excel met 10000 lijnen ook wel werken. Ik doe dit liever niet manueel. Het excel bestand in bijlage zodat het probleem duidelijk is.
 
Laatst bewerkt:
Mij is het niet duidelijk. In de tab 'Betondekking' komt 18 keer 'FQ_00413010_003131.CSV' voor in kolom A. In de tab 'Resultaten' komt deze waarde 1 keer voor. Waarheen het gekopieerd moet worden staat ook nergens. Dus wat is de bedoeling?
 
zoiets?

Code: 
Sub sjon()
Application.ScreenUpdating = False
    For Each cl In Sheets("Betondekking").Range("A2:A250")
        If Application.CountIf(Sheets("Resultaten").Range("A2:A500"), cl.Value) Then
            cl.Offset(, 3).Value = Sheets("Resultaten").Range("A2:A500").Find(cl.Value).Offset(, 1).Value
            cl.Offset(, 4).Value = Sheets("Resultaten").Range("A2:A500").Find(cl.Value).Offset(, 2).Value
            cl.Offset(, 5).Value = Sheets("Resultaten").Range("A2:A500").Find(cl.Value).Offset(, 3).Value
        End If
    Next cl
Application.ScreenUpdating = True
End Sub
 
Ik dacht meer aan dit.
Zie tabblad betondekking en na de code zie blad1 (lijkt mij dan identiek aan 'betondekking' in het voorbeeldbestand op kolom 3 na).
 

Bijlagen

  • Betondekkingen NZ test.xlsb
    54,2 KB · Weergaven: 34
Zo bedoel je?

Code: 
Sub hsv()
Dim sv, hs, i As Long, ii As Long, zoek
Application.ScreenUpdating = False
sv = Sheets("resultaten").Cells(1).CurrentRegion
With Sheets("betondekking").ListObjects(1)
.Range.AutoFilter 3
 hs = .DataBodyRange.Value
    For i = 2 To UBound(sv)
     zoek = Application.Match(Split(sv(i, 1), "/")(1), .Range.Columns(1), 0)
        If Not IsError(zoek) Then
          For ii = zoek To zoek + sv(i, 5) - 1
             hs(ii, 4) = sv(i, 2)
             hs(ii, 5) = sv(i, 3)
             hs(ii, 6) = sv(i, 4)
          Next ii
        End If
    Next i
 .DataBodyRange.Value = hs
 .Range.AutoFilter 3, "<>"
End With
End Sub

Nb. druk op de reageerknop i.p.v. de citeerknop!
De berichten hoef ik niet opnieuw te lezen, ik heb ze immers zelf geschreven.
 
Laatst bewerkt:
Moet dit er ook nog niet ergens tussen?
Code: 
Application.ScreenUpdating = true
 
Nee, gaat automatisch.
 
Lijkt me lastig: VBA in een xlsx bestand.

In een .xlsb bestand:

Code: 
Sub M_snb()
  sn = Sheets("Betondekking").ListObjects(1).DataBodyRange.Resize(, 5)
  sp = Sheets("resultaten").Cells(1).CurrentRegion
   
  With CreateObject("scripting.dictionary")
    For j = 2 To UBound(sp) - 3
      .Item(Split(sp(j, 1), "/")(1)) = Array(sp(j, 2), sp(j, 3))
    Next
      
    For j = 1 To UBound(sn)
      st = .Item(sn(j, 1))
      sn(j, 4) = st(0)
      sn(j, 5) = st(1)
    Next
  End With
   
  Sheets("Betondekking").ListObjects(1).DataBodyRange.Resize(, 5) = sn
End Sub
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan