Automatisch rows invoegen aan de hand van unieke nummers

Status
Niet open voor verdere reacties.

warmerfare

Nieuwe gebruiker
Lid geworden
17 mrt 2017
Berichten
4
Hey beste lezer,

Ik zit met een vraagstuk waar ik maar geen oplossing voor kan vinden.:confused: Ik wil namelijk automatisch rows overschijven met ge-update informatie aan de hand van unieke nummers in kolom A.

Dit is hoever ik ben gekomen:

Sub ifequaldo()
Dim rngName As Range, rngNames As Range
Set rngNames = Range("A" & Rows.Count)
For Each rngName In rngNames
If rngName.Value = "A" & Rows.Count Then
ActiveCell.Select = ("A8")
End If
Next rngName
End Sub

Nu zou dit simpele scriptje ervoor moeten zorgen dat cell A8 geselecteerd word (ik haal namelijk de waardes uit dezelfde bron als dat deze mee gecontroleerd worden, dus de uitkomst zou altijd TRUE moeten zijn) alleen doe ik iets fout, want de cel word niet geselecteerd :(

Iemand enig idee wat ik verkeerd doe?

Het uiteindelijke doel is om voor unieke nummers die al in het document staan de row te overschrijven met nieuwe data, en voor unieke nummers die nog niet in het document staan de cel onder de onderste regel selecteren en daar vervolgens de row in te voegen. De bron is standaard een nieuw aangemaakt werkboek (book1) waar de rows in geplakt zijn uit ons systeem. (de kolommen zijn in deze 2 document exact hetzelfde op de verschillende waardes in cellen na).

Alvast bedankt
Mvg, Jerry
 
Doe er eens een voorbeeldje bij, dat kijkt een stuk makkelijker. En dan hoeven we de startsituatie niet na te bouwen, wat ons uiteraard ook (kostbare) tijd kost.
 
https://www.dropbox.com/s/tb9pg1vkjcb1qg7/Book1.xlsm?dl=0

Hierboven het dropbox linkje naar mijn voorbeeld file. Ik kan helaas de oorspronkelijke files niet uploaden gezien hier gevoelige bedrijfsinformatie in aanwezig is.
Het rare is nu dat hij altijd "hello" print ongeacht of de waarde van mijn range overeenkomt met de aangewezen cel :confused:

De acties die gewenst zijn als de cel informatie hetzelfde is heb ik nog niet in de macro opgenomen, maar hier ben ik bekend mee dus dit zal geen probleem zijn.

Het voorbeeld is opgebouwd uit 2 sheets, bron en data. Bron staat voor het te importeren gedeelte data, en de sheet data staat voor de bestemming.
In kolom A staan de unieke nummers, aan de hand hiervan moeten de rows ingevoegd worden (als het nummer hetzelfde is, overschrijf de row met ge-update informatie, als het nummer niet hetzelfde is moet hij de row onder de laatste row met data in de data sheet zetten.)

In mijn ogen zou dit een relatief eenvoudige code moeten zijn, maar ik krijg hem maar niet werkend:(

Degene die mij de oplossing kan presenteren, of dit bericht alleen al leest met de intensie om me te helpen. Ik ben je alvast super dankbaar ^^
 
Laatst bewerkt:
Probeer het zo eens

Code:
Sub VenA()
Dim f As Range
  With Sheets("DATA DOCUMENT")
    For Each cl In Sheets("Bron").Columns(1).SpecialCells(2)
      Set f = .Columns(1).Find(cl.Value, , xlValues, xlWhole)
      If f Is Nothing Then .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 5) = cl.Resize(, 5).Value Else f.Resize(, 5) = cl.Resize(, 5).Value
    Next cl
  End With
End Sub
 
Je bestand bij dropbox blijft daar niet eeuwig staan.
Als je het bestand hier in het forum plaatst blijft het onderdeel uitmaken van deze draad.
Wel zo handig/sympathiek voor latere forumbezoekers.

Bijkomend voordeel, dan kijk ik er misschien ook naar.
 
Laatst bewerkt:
Hey iedereen,

Sorry voor de late reactie, ik ben enorm in de weer geweest met het geweldige stukje code wat je me aangereikt had :)

Ik heb trouwens direct even een nieuw voorbeeld bestand geupload via de goede manier, alleen dit keer mijn daadwerkelijke werkbestand zonder de gevoelige data, maar met de macro's :)

Dit is hem voor mij uiteindelijk geworden:
Code:
Sub VanBronNaarBase()
Dim f As Range
Dim d As Range
  With Sheets("Database")
    For Each cl In Sheets("Bron data aktiesport").Columns(1).SpecialCells(2)
      Set f = .Columns(1).Find(cl.Value, , xlValues, xlWhole)
      If f Is Nothing Then .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 54) = cl.Resize(, 54).Value Else f.Resize(, 54) = cl.Resize(, 54).Value
    Next cl
End With
  With Sheets("Database")
    For Each cl In Sheets("Bron data perrysport").Columns(1).SpecialCells(2)
        Set d = .Columns(1).Find(cl.Value, , xlValues, xlWhole)
        If d Is Nothing Then .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(, 54) = cl.Resize(, 54).Value Else f.Resize(, 54) = cl.Resize(, 54).Value
    Next cl
End With
End Sub

Hij doet echt precies wat ik voor ogen had wat ik wou dat hij deed, alleen hij is extreem langzaam :( Deze code 1 keer uitvoeren kost mij +15 minuten :eek: (misschien is dat omdat ik 40.000 rows in mijn database heb met 20.000 rows brondata die ingevoegd moet worden)

Nu dacht ik na over het volgende, alleen is mij niet bekend in hoeverre dit (gemakkelijk) mogelijk te maken is:
Kolom A Uit Brondata naar range A
Kolom A Uit Database naar range B
Range A vergelijken met Range B en alle waardes die in beide ranges voorkomen naar Range C te schrijven, alle waardes die naar Range C geschreven worden zouden verwijderd moeten worden uit Range A
Range C invoegen via de hiervoor aan mij aangereikte code, Range A onder de laatste row met data invoegen

Is dit realiseerbaar?
 

Bijlagen

  • oploadbestand.xlsm
    895 KB · Weergaven: 26
Dit pak je gemakkelijk en snel aan met een dictionary.
 
Plaats een gelijkend voorbeeld met data erin. Verder begrijp ik niet zoveel van de sub 'CreeërUniekeKenmerken'. Als je die extra kolommen al nodig denkt te hebben dat kan je het beter zo doen

Code:
Sub VenA()
For Each sh In Sheets
  If InStr(sh.Name, "sport") Then
    sh.Columns("A:B").Insert
    ar = sh.Cells(1, 3).CurrentRegion.Offset(, -2).Resize(, 26)
    For j = 2 To UBound(ar)
      ar(j, 2) = Split(sh.Name)(UBound(Split(sh.Name)))
      ar(j, 1) = ar(j, 3) & ar(j, 23) & ar(j, 26) & ar(j, 2)
    Next j
    sh.Cells(1).Resize(UBound(ar), UBound(ar, 2)) = ar
  End If
Next sh
End Sub

Het werken met array's/collections gaat veel sneller dan het steeds weer ophalen en wegschrijven van gegevens naar een werkblad.
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan