IDnr. doortellen

Status
Niet open voor verdere reacties.
U

Ukkie1964

Gebruiker
Lid geworden
10 okt 2018
Berichten
11
Goedendag Allemaal,

Ik ben aan het stoeien geweest met een klein programmaatje.
Het lukt me vrij aardig.
Alleen ik zit met een probleempje.
Allereerst het probleempje:
Ik heb gegevens staan op het controleblad.
Als er nieuw in de regel staat wil ik de bekende gegevens kopieren naar het datablad, zodat deze deelnemer bekend is voor de volgende keer.
Ik krijg deze gegevens wel gekopieerd, alleen dan zou er een IDnr. aangemaakt moeten worden 1 hoger dan het tot dan toe hoogste IDnr.
Dit krijg ik niet voor elkaar, wat ik ook probeer.
Ik heb de code uit een ander bestand waar de code wel werkt, maar in mijn nieuw bestand niet.
De codes die ik geprobeerd heb zijn:
Code: 
NieuwId = WorksheetFunction.Max(Worksheets("Datablad").Range("A:A")) + 1
en
Code: 
nummer = Application.WorksheetFunction.Max(Worksheets(2).Range("A:A")) + 1
Maar bij beide word er geen uniek IDnr. gegenereerd.
Wat doe ik fout??
Hierbij het bestandje waar het om gaat.
 

Bijlagen

  • Test kopieren gegevens.xlsm
    59,1 KB · Weergaven: 25
Macro aangepast
 

Bijlagen

  • Kopie(jp) van Test kopieren gegevens.xlsm
    64,8 KB · Weergaven: 23
Goedenavond JeanPaul28

Hoe simpel kan het zijn.
Het doet precies zoals ik het hebben wil.
Dank je wel voor de geboden
hulp:thumb::thumb::thumb:
 
Zet er de rode tekst ook tussen dan kan er maar alleen een Id aangemaakt worden als er nieuw staat in de cel ID Nr

Code: 
Sub KopierenNaarData()
Dim NieuwId As Integer


'Bepalen van de geselecteerde regel
Regel = Selection.Row


With Worksheets("Controleblad")
[COLOR="#FF0000"]If .Cells(Regel, 3).Value <> "nieuw" Then Exit Sub[/COLOR]
    Naam = .Range("B" & Regel).Value2
    Plaats = .Range("H" & Regel).Value2
    Geboortedatum = .Range("K" & Regel).Value2
    Vereniging = .Range("L" & Regel).Value2
    
End With

'Gegevens schutter kopieren
With Worksheets("Datablad")
    LegeRegel = .Cells(Rows.Count, "b").End(xlUp).Row + 1
    NieuwId = WorksheetFunction.Max(Blad3.Range("A:A")) + 1
    sq = Array(NieuwId, Naam, Vereniging, Plaats, Geboortedatum)
    '.Cells(LegeRegel, "a").Value = ID
    .Cells(LegeRegel, "A").Resize(1, 5).Value = sq
    .Cells(LegeRegel, "A").Offset(0, 4).NumberFormat = "m/d/yyyy"
    '.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    
End With



End Sub
 
Dank u wel voor de tip.
ik was er ook al mee bezig om alleen nieuwe deelnemers in te kunnen schrijven.
Dit werkte ook prima
Nu heb ik zoiets als er geen nieuw in de cel van IDnr. staat is het wel zo mooi dat er een melding komt dat deze deelnemer al in de lijst staat.
deze melding krijg ik wel alleen als ik een nieuwe deelnemer wil invoeren werkt het niet meer.
ik had deze oplossing alleen die werkt niet.
Code: 
    If .Cells(Regel, 3).Value <> "nieuw" Then
    MsgBox ("Deze deelnemer staal al in de lijst")
    End If
    Exit Sub
 
zie tekst in rood
Code: 
With Worksheets("Controleblad")
[COLOR="#FF0000"]If .Cells(Regel, 3).Value <> "nieuw" Then MsgBox "Deze deelnemer staal al in de lijst": Exit Sub[/COLOR]
    Naam = .Range("B" & Regel).Value2
    Plaats = .Range("H" & Regel).Value2
    Geboortedatum = .Range("K" & Regel).Value2
    Vereniging = .Range("L" & Regel).Value2
    
End With
 
Goedemiddag JeanPaul

Ik had er haakjes omheen staan en dat werkte niet.
Nu werkt het wel dank je wel voor de geboden oplossing.

:thumb::thumb::thumb:
 
Zonder overbodige melding en alles in 1 keer

Code: 
Sub VenA()
  ar = Sheets("Controleblad").Cells(3, 2).CurrentRegion
  ReDim ar1(4, 0)
  With Sheets("Datablad")
    t = Application.Max(.Columns(1))
    For j = 2 To UBound(ar)
      If ar(j, 2) = "nieuw" Then
        b = -1
        t = t + 1
        ar1(0, UBound(ar1, 2)) = t
        ar1(1, UBound(ar1, 2)) = ar(j, 1)
        ar1(2, UBound(ar1, 2)) = ar(j, 11)
        ar1(3, UBound(ar1, 2)) = ar(j, 7)
        ar1(4, UBound(ar1, 2)) = Format(ar(j, 10), "mm-dd-yyyy")
        ReDim Preserve ar1(4, UBound(ar1, 2) + 1)
      End If
    Next j
    If b Then .Cells(Rows.Count, 1).End(xlUp).Offset(1).Resize(UBound(ar1, 2), 5) = Application.Transpose(ar1)
  End With
End Sub
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan