Zoek nieuwe namen in data dump tabblad 2

Status
Niet open voor verdere reacties.
D

drubbus

Gebruiker
Lid geworden
20 feb 2013
Berichten
121
Ik heb hier een heel gaaf bestand gevonden om nieuwe medewerkers vanuit de dump in een data blad te kopiëren .
Werkt prachtig maar als er in de dump lege rijen voorkomen stopt het kopiëren naar het tabblad.
Ik heb voor de functie Copy gekozen ipv ClearContents .

Nu kun je natuurlijk de lege rijen uit het tabblad dump halen maar in mijn geval moeten die juist blijven staan staan .


De vraag is dus eigenlijk , of er na een blanco rij verder gezocht kan worden naar nieuwe medewerkers op het dump blad
Code: 
Sub Knop1_Klikken()
x = Range([a1], [a1].End(xlDown)).Rows.Count
For Each cell In Range("a2:a" & x)
n = cell.Value
    With Sheets("blad1")
    Set nr = .Range("a1:a500").Find(n, lookat:=xlWhole)
        If Not nr Is Nothing Then
        cell.Resize(, 2).ClearContents
       Else
        .Range("a500").End(xlUp).Offset(1).Resize(, 2) = cell.Resize(, 2).Value
        cell.Resize(, 2).ClearContents
       End If
     End With
Next
End Sub
 

Bijlagen

  • VBA nieuwe namen onderaan .xlsm
    20,9 KB · Weergaven: 26
Laatst bewerkt:
Probeer eens met de eerste instructie te vervangen door
Code: 
x = Cells(Rows.Count, 1).End(xlUp).Row
 
Super

Dit is wat ik zocht !
Heel erg bedankt dit scheelt mij heel veel werk Enigmasmurf :thumb:
 
Als je tabellen gebruikt hoef je niet opzoek naar de laatste rij.

Bij veel gegevens gaat het zo sneller.
Code: 
Sub VenA()
  ar1 = Sheets("Blad2").ListObjects(1).DataBodyRange
  Set d = CreateObject("Scripting.Dictionary")
  With Sheets("Blad1").ListObjects(1)
    ar = .DataBodyRange
    For j = 1 To UBound(ar)
      If ar(j, 1) <> "" Then d(ar(j, 1)) = Array(ar(j, 1), ar(j, 2))
    Next j
    For j = 1 To UBound(ar1)
      If ar1(j, 1) <> "" Then d(ar1(j, 1)) = Array(ar1(j, 1), ar1(j, 2))
    Next j
    .DataBodyRange.Delete
    .ListRows.Add.Range.Resize(d.Count, 2) = Application.Index(d.items, 0, 0)
  End With
  Sheets("Blad2").ListObjects(1).DataBodyRange.Delete
End Sub
 
Code: 
Sub hsv()
With Sheets("blad2").ListObjects(1).DataBodyRange
  sv = .Value
  Sheets("blad1").ListObjects(1).ListRows.Add.Range.Resize(UBound(sv)) = sv
  .Delete
End With
Sheets("blad1").ListObjects(1).DataBodyRange.RemoveDuplicates 1
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan