Dubbele gegevens vermijden met vba

[rg027]

Beste,

Ik heb een map waarin in blad 1 taken worden toegewezen op datum. Datum komt in kolom a en de taken in kolom b. Indien een taak is afgehadeld wordt in kolom c de datum van afhandeling te staan.
Via vba worden de afgehandelde taken weggeschreven naar een blad.( taak a naar blad 2, taak b naar blad 3 , enz.) Dit lukt me allemaal goed. Ook het verwijderen van de afgewerkte taken in blad 1 vormt geen probleem.
Wat ik nu zou willen (ik kom er niet uit) is eens een taak is toegewezen of afgehandeld is, deze niet meer in blad a mag bijgeschreven worden.(dubbels vermijden dus) Om te vergelijken heb ik in kolom d van elk werkblad een formule gezet die unieke waarden maakt ( formule : als(a1="";"";tekst(a1;"d.m.j")&" "& a2) zo krijg je bvb de unieke waarde "1/1/07 A" waarvan 1/1/07 de datum is en "A" de taak.
Iemand enig idee hoe dit kan verwezenlijkt worden met vba?
Ik zou anders men bestand toevoegen maar is te groot.

hopelijk is men uitleg wat duidelijk.
Alvast hartelijke dank

 

[Demeter]

Kan je misschien toch een voorbeeld aanhangen. Kom niet geheel uit je vraag stelling.
misschien alleen de 1e 20 regels vullen met data?

 

[Wigi]

misschien alleen de 1e 20 regels vullen met data?

Ja, en dit op elk van de 3 tabbladen.

 

[rg027]

Bedoeling is dat gegevens die al in blad 2 ,blad 3 en blad 4 zijn toegevoegd, niet meer mogen toegevoegd worden om geen dubbele gegevens te hebben.

In blad 1 worden de gegevens ingevoerd en eenmaal afgehandeld(datum in kolom c van blad 1) worden deze naar het juiste werkblad weggeschreven.

 

[Demeter]

Let op code is nog niet geheel werkende!!!
Weinig tijd om de puntjes op de i te zetten (weertje buiten he )
Hij stopt met over zetten als hij de 1e dubbele heeft gevonden. Aangezien ik dit erg vreemd vindt kom ik er niet zo 1 2 3 uit. Maar denk dat de bedoeling wel duidelijk is.
Tevens heb ik je blad namen wat aangepast zodat deze door de code kunnen worden gehaald, heb je niet voor iedere letter een nieuw script nodig.

Code:

Sub overzetten()
Dim c As Range
Dim laatsteregel, legeregel As Long
Dim rFound As Range
Dim teller As Long

teller = 0
laatsteregel = Sheets("Blad1").Range("B65536").End(xlUp).Row

    For Each c In Range("B2:B" & laatsteregel)
        If c.Value <> "" Then
        
            legeregel = Sheets("Blad " & c.Value).Range("A65536").End(xlUp).Row + 1

            With Sheets("Blad " & c.Value)
                
                On Error Resume Next
                
                Set rFound = .Columns(4).Find(What:=c.Offset(, 2).Value, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Rows
    
                If rFound Is Nothing Then
                    Range("A" & c.Row).EntireRow.Copy Sheets("Blad " & c.Value).Range("A" & legeregel)
                    teller = teller + 1
                End If
                
            End With
            
        End If
    Next
    
    MsgBox "Er zijn in totaal: " & teller & " rijen overgezet!"

End Sub

Succes

ps.
ik ga er geen gewoonte van maken om incorrecte of 1/2 codes te posten, alleen nu komt het erg slecht uit, vandaar. Excuus.

 

[rg027]

Bedankt voor je reaktie.

Ik heb deze uitgeprobeerd en de code stop idd als er een dubbel gevonden is.
Wat er niet gebeurt is dat de weggeschreven gegevens mogen verwijderd wworden in blad 1. De aangepaste code om weg te schrijven is veel korter (weer iets bijgeleerd)
Verder begrijp ik een stuk van de code niet

      Set rFound = .Columns(4).Find(What:=c.Offset(, 2).Value, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext).Rows
    
                If rFound Is Nothing Then
                    Range("A" & c.Row).EntireRow.Copy Sheets("Blad " & c.Value).Range("A" & legeregel)
                    teller = teller + 1
                End If

 

[Demeter]

Probeer deze code eens (zat hem in de find functie):

Sub overzetten()
Dim c As Range
Dim laatsteregel, legeregel, laatsteregel2 As Long
Dim rFound As Range
Dim teller As Long

Application.ScreenUpdating = False

teller = 0
laatsteregel = Sheets("Blad1").Range("B65536").End(xlUp).Row

    For Each c In Sheets("Blad1").Range("B2:B" & laatsteregel)
        If c.Value <> "" Then
            laatsteregel2 = Sheets("Blad " & c.Value).Range("D65536").End(xlUp).Row
            'kijk in "Blad + letter" in kolom D
            With Sheets("Blad " & c.Value).Range("D2:D" & laatsteregel2)
                'Vul de variabele d met de uitkomst van het zoeken naar je dubbele
                Set d = .Find(c.Offset(, 2), LookIn:=xlValues)
                    'als er geen dubbele zijn ga verder
                    If d Is Nothing Then
                        'zoek legeregel om de niet dubbele te plakken
                        legeregel = Sheets("Blad " & c.Value).Range("A65536").End(xlUp).Row + 1
                        'kopieer volledige regel
                        Range("A" & c.Row).EntireRow.Copy Sheets("Blad " & c.Value).Range("A" & legeregel)
                        'zet de teller 1 hoger
                        teller = teller + 1
                    End If
            End With
        End If
    Next

Sheets("Blad1").Range("A2:C" & laatsteregel).ClearContents

MsgBox "Er zijn in totaal: " & teller & " rijen overgezet!"

Application.ScreenUpdating = True

End Sub

 

[rg027]

Hartellijke dank.
Deze doet het goed , enkel als er in kolom b (van blad a geen gegevens ingevuld zijn komt er een foutmeldig + indien in kolom c geen gegevens zijn ingevuld worden de gevens toch verwijderden weggeschreven..De gevens mogen enkel verwijderd worden als er afwel dubbele gegevns zijn owel kolom c is ingevuld

 

[Demeter]

Kijk deze eens door:

Sub overzetten()
Dim c As Range
Dim laatsteregel, legeregel, laatsteregel2 As Long
Dim teller As Long

Application.ScreenUpdating = False

teller = 0
laatsteregel = Sheets("Blad1").Range("A65536").End(xlUp).Row

    For Each c In Sheets("Blad1").Range("B2:B" & laatsteregel)
        If c.Value <> "" And c.Offset(, 1).Value <> "" Then
            laatsteregel2 = Sheets("Blad " & c.Value).Range("D65536").End(xlUp).Row
            'kijk in "Blad + letter" in kolom D
            With Sheets("Blad " & c.Value).Range("D2:D" & laatsteregel2)
                'Vul de variabele d met de uitkomst van het zoeken naar je dubbele
                Set d = .Find(c.Offset(, 2), LookIn:=xlValues)
                    'als er geen dubbele zijn ga verder
                    If d Is Nothing Then
                        'zoek legeregel om de niet dubbele te plakken
                        legeregel = Sheets("Blad " & c.Value).Range("A65536").End(xlUp).Row + 1
                        'kopieer volledige regel
                        Range("A" & c.Row).EntireRow.Copy Sheets("Blad " & c.Value).Range("A" & legeregel)
                        'zet de teller 1 hoger
                        teller = teller + 1
                    End If
            End With
            
            c.EntireRow.ClearContents

        End If
    Next

'sorteer de data zodat er geen legen regels tussen zitten
'1e sorteren op kolom B dan op A en als latste op C
    Sheets("Blad1").Range("A2:D" & laatsteregel).Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2") _
        , Order2:=xlAscending, Key3:=Range("C2"), Order3:=xlAscending, Header:=xlGuess

MsgBox "Er zijn in totaal: " & teller & " rijen overgezet!"

Application.ScreenUpdating = True

End Sub