• 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.

Automatich omnummer

Status
Niet open voor verdere reacties.
M

malawi

Gebruiker
Lid geworden
10 mrt 2009
Berichten
169
Ik heb een excel bestand met op Tabblad "Nieuw" kolom A de oude nummers en in kolom B de nieuwe nummering.
Nu wil ik graag op tabblad "Overzicht" alle oude nummer vervangen door de nieuwe nummering.
Op tabblad "Overzicht" komt regelmatig voor, dat een nummer vaker voorkomt voor verschillende objecten.

Hoe is dit via VBA te realiseren?

Bij voorbaat dank,

Ewald
 
Ik heb een mogelijke oplossing:

Code: 
Option Explicit

Sub Omnummeren()
    Dim rngLoop As Range
    Dim colOverzicht As Collection
    Dim lngRegel As Long
    
    Set colOverzicht = New Collection
    
    ' Een collection bevat key-value paren aan infomatie
    ' vul colOverzicht met
    '     het oude nummer als key
    '     net nieuwe nummer als value
    
    With Sheets("Overzicht_L")
        lngRegel = 2
        While Not IsEmpty(.Cells(lngRegel, 1))
            colOverzicht.Add .Cells(lngRegel, 2), Key:=.Cells(lngRegel, 1)
            lngRegel = lngRegel + 1
        Wend
    End With
    
    ' gebruikt de collection on de gegevens aan te passen
    With Sheets("Nieuw")
        lngRegel = 1
        While Not IsEmpty(.Cells(lngRegel, 1))
            .Cells(lngRegel, 1) = colOverzicht(.Cells(lngRegel, 1))
            lngRegel = lngRegel + 1
        Wend
    End With
End Sub

Ik hoop dat dit helpt.
 
Is dit niet voldoende? In blad 'Nieuw' B1

Code: 
=VERT.ZOEKEN(A1;Overzicht_L!$A$1:$B$17;2;0)
 
Lijkt me wel,

Maar als je liever VBA gebruikt:

Code: 
Sub M_snb()
    [Nieuw!B1:B200] = [if(Nieuw!A1:A200="","","=" & address(match(Nieuw!A1:A200,Overzicht_L!$A$1:$A$2000,0),2,,,"Overzicht_L"))]
End Sub
 
De oplossing van WoutMag werkt uitstekend in het voorbeeld bestand, nu heb ik een bestand waar over verschillende werkbladen de nummering staat. hoe kan ik deze nog aanpassen zodat de omnummering over de gehele werkmap plaats vind op elke willekeurige plek.

Alvast bedankt
 
Bv.

Code: 
Sub VenA()
  Set d = CreateObject("Scripting.Dictionary")
  ar = Sheets("Overzicht_L").Cells(1).CurrentRegion
  For j = 2 To UBound(ar)
    d.Item(ar(j, 1)) = ar(j, 2)
  Next j
  For Each sh In Sheets
    If sh.Name <> "Overzicht_L" Then
      ar = sh.UsedRange
      For j = 1 To UBound(ar)
        For jj = 1 To UBound(ar, 2)
          If d.exists(ar(j, jj)) Then ar(j, jj) = d.Item(ar(j, jj))
        Next jj
      Next j
      sh.UsedRange = ar
    End If
  Next sh
End Sub
 
Het heeft even geduurd maar inmiddels heb ik deze getest. In mijn test bestand loopt het uitstekend, maar wanneer ik deze uitvoer in het origineel dan loopt het vast op regel "sh.UsedRange = ar" Wat zou hier de oorzaak van kunnen zijn.
Tevens wat worden alle formules verwijderd. Dit is uiteraard niet de bedoeling.

Ewald
 
Laatst bewerkt:
hallo,

Als voorbeeld bestand toegevoegd. Hierbij een kolom toegevoegd met een verwijzing. en een sommetje als formule. Als ik de macro uitvoeren wordt de verwijzing ook omgezet in tekst. en de formule is weg.
het moet zijn zoals als de functie "zoeken en vervangen" maar dan vanuit een lijst in een werkblad welke in de werkmap is toegevoegd.

Bij voorbaat dank,

Ewald
 

Bijlagen

Code: 
Sub VenA()
  Set d = CreateObject("Scripting.Dictionary")
  ar = Sheets("Overzicht_L").Cells(1).CurrentRegion
  For j = 2 To UBound(ar)
    d.Item(ar(j, 1)) = ar(j, 2)
  Next j
  For Each sh In Sheets
    If sh.Name <> "Overzicht_L" Then
      [COLOR="#FF0000"]ar = sh.Columns(1).SpecialCells(2)[/COLOR]
      For j = 1 To UBound(ar)
        For jj = 1 To UBound(ar, 2)
          If d.exists(ar(j, jj)) Then ar(j, jj) = d.Item(ar(j, jj))
        Next jj
      Next j
      [COLOR="#FF0000"]sh.Cells(1).Resize(UBound(ar)) = ar[/COLOR]
    End If
  Next sh
End Sub
 
Die formule in kolom D is een denkfout.

Code: 
Sub M_snb()
  sn = Blad1.Cells(1).CurrentRegion
  
  For Each it In Sheets
    If it.CodeName <> "Blad1" Then
        For j = 2 To UBound(sn)
          it.Cells.Replace sn(j, 1), sn(j, 1) & ";" & sn(j, 2), 1
        Next
        
        it.Columns(1).TextToColumns , , , , 0, -1, 0, 0
    End If
  Next
End Sub
 
Laatst bewerkt:
het script van Ven werkt uitstekend in mijn test Werkmap, Maar wanneer het script overzet naar het origineel bestand loopt het niet door.
Ik heb inmiddels alle werkbladen die in het bestand zitten (welke trouwens niet bewerkt hoeven te worden) de beveiliging verwijderd.


Zie bijlage.

Waar zou ik dit probleem kunnen zoeken?

Kan helaas het origineel bestand niet uploaden.

Ik denk dat het probleem is dat de originele nummer niet opeenvolgend in mijn lijst staan. Ze staan wel op verschillende werkbladen in 1 kolom maar met tussen ruimtes. Zie bijlage.

Ewald
 

Bijlagen

Laatst bewerkt:
Jammer, dat gaat helaas niet. Er staat in een andere kolom info op deze regel. Kan ook niet rangschikken. Wanneer ik de functie "zoeken en vervangen" gebruik 1 voor 1 gaat het goed, kris kras door de werkmap, maar als je dit tig maal moet doen is het minder. Zou dit graag automatisch vanuit een lijst doen.
 
Als je de suggestie in #5 had toegepast dan was je al lang klaar geweest. (hooguit 10 minuten werk) Bijna 3 maanden bezig om een paar artikelnummers om te zetten zonder enige kennis van VBA:rolleyes:
 
Laatst bewerkt:
suggestie in #5 kan ik helaas niet toepassen. Alle kollommen in mijn overzicht staan vast. ik kan er geen hulpkolom bij tussen zetten. IK heb geen ander mogelijkheid.

Suggestie in #8 gaat het omnummeren door het de hele werkmap goed. Alleen hierbij wordt alle formules in overige cellen vervangen voor "0"
 
Laatst bewerkt:
Status
Niet open voor verdere reacties.
                    Steun ons                    

Nieuwste berichten

Terug
Bovenaan Onderaan