verticaal zoeken en vastzetten met een macro

Status
Niet open voor verdere reacties.
M

Miilan0

Gebruiker
Lid geworden
11 nov 2011
Berichten
6
Goedemorgen allemaal,

Ik ben hier nieuw en ben sinds een maand bezig met excel. Nu heb ik de basis wel redelijk onder de knie, maar nu wil ik een macro schrijven om mijn bestand ook voor andere mensen werkbaar te maken, zodat er zo weinig mogelijk tijd verloren gaat aan het invullen van het bestand.

Ik ben echt al een tijdje aan het zoeken, maar heb helaas nog niks kunnen vinden wat toepasbaar is. Als iemand een link weet met dezelfde vraag, zou diegene dan zo vriendelijk kunnen zijn om deze link door te zenden.

Achtergrond:
-Excel 2003
Ik heb een lijst van rond de 1000 rijen en iets van 20 kolommen. Deze lijst bevat documenten die elke week worden ingeleverd om te worden nagekeken.
-Wanneer ze binnen komen krijgen ze de datum van binnenkomst.
-Nu worden ze nagekeken en beoordeeld. Dit kan zijn Rejected, For Review, Comments of Accepted.
Wanneer het bestand Accepted is, is deze klaar voor gebruik.

Elke week komen er ongeveer 20 documenten binnen, waarvan 10 nieuwe en 10 revisies, die opnieuw beoordeeld moeten worden. De verwachting is dat dit de komende weken op gaat lopen naar 50 per week.

2 keer per week wordt er een Dump gemaakt uit een programma en in Excel geladen. de DUMP is ook een .xls bestand. Bekijk bijlage hulpgevraagd.xls

Acties:

-De DUMP wordt geladen in het tabblad DUMP. is een excel bestand.
-Door het No(welke uniek is) moet hij de nieuwe gegevens automatisch updaten in het tabblad OVERVIEW.
-Alles wat gevonden is, moet automatisch verwijderd worden uit de DUMP lijst.
-Hierna moet de dumplijst weer leeg zijn, voor de volgende dump.
-De OVERVIEW Lijst moet gevuld blijven. Ook wanneer de DUMP weer leeg wordt gemaakt.


Ik hoop dat het duidelijk is!

alvast bedankt voor de hulp!
 
Ik neem aan dat het een copy/paste foutje is, maar er staan meerdere document "34" in het voorbeeld. Ik neem aan dat dat normaal niet voorkomt?
 
een foutje

excuses. U hebt gelijk.
Normaal moet deze gewoon doortellen. het is inderdaad een copy/paste foutje.
 
De code delete nog niets, maar volgens mij dekt dit de meeste use-cases.

Code: 
Sub overboeken()
    For Each boek In Range(Sheets("DUMP").[a3], Sheets("DUMP").[a50000].End(xlUp))
        Set zoeken = Range(Sheets("OVERVIEW").[a3], Sheets("OVERVIEW").[a50000].End(xlUp)).Find(boek.Value, , , xlWhole)
        If Not zoeken Is Nothing Then
            With zoeken
                .Value = boek
                .Offset(0, 1) = boek.Offset(0, 1)
                .Offset(0, 2) = boek.Offset(0, 2)
                .Offset(0, 4) = boek.Offset(0, 3)
                .Offset(0, 5) = boek.Offset(0, 4)
            End With
        Else
            With Sheets("OVERVIEW").[a50000].End(xlUp).Offset(1)
                .Value = boek
                .Offset(0, 1) = boek.Offset(0, 1)
                .Offset(0, 2) = boek.Offset(0, 2)
                .Offset(0, 3) = boek.Offset(0, 3)
                .Offset(0, 5) = boek.Offset(0, 4)
            End With
        End If
        
    Next boek
End Sub
 
Dit is inderdaad wat ik bedoel. Heel erg bedankt voor de snelle reactie! Dit was mij zelf niet zo snel gelukt.:thumb:

Is het ook mogelijk, wanneer het document nog niet eerder ingeleverd is, dat de submission datum van de DUMP onder de First Revision komt te staan?

En wanneer ik de titel van de DUMP niet mee wil laten veranderen, omdat deze soms verschillen met de titels in OVERVIEW, moet een aanpassing doen aan .Offset?

Nogmaals bedankt voor uw hulp!
 
Het eerste gebeurd al, als het goed is. verander NO in dump naar bijv 99 en run de macro. er wordt nu een nieuwe regel toegevoegd met '99' en de datum in "first submit". Tenzij er ook een ander scenario denkbaar is?

Het tweede kan door de "offset 2" in de eerste if niet te gebruiken.
 
Het gebeurt inderdaad wel als het No in de OVERVIEW mist.
In mijn geval is de OVERVIEW al compleet ingevuld, behalve de rev, de submission en de status.
 
Kleine aanpassing dan:

Code: 
Sub overboeken()
    For Each boek In Range(Sheets("DUMP").[a3], Sheets("DUMP").[a50000].End(xlUp))
        Set zoeken = Range(Sheets("OVERVIEW").[a3], Sheets("OVERVIEW").[a50000].End(xlUp)).Find(boek.Value, , , xlWhole)
        If Not zoeken Is Nothing Then
            With zoeken
                .Value = boek
                .Offset(0, 1) = boek.Offset(0, 1)
                '.Offset(0, 2) = boek.Offset(0, 2)
                If .Offset(0, 3) = "" Then
                    .Offset(0, 4) = boek.Offset(0, 3)
                Else
                    .Offset(0, 4) = boek.Offset(0, 3)
                End If
                .Offset(0, 5) = boek.Offset(0, 4)
            End With
        Else
            With Sheets("OVERVIEW").[a50000].End(xlUp).Offset(1)
                .Value = boek
                .Offset(0, 1) = boek.Offset(0, 1)
                .Offset(0, 2) = boek.Offset(0, 2)
                .Offset(0, 3) = boek.Offset(0, 3)
                .Offset(0, 5) = boek.Offset(0, 4)
            End With
        End If
        
    Next boek
End Sub
 
lijkt me iets simpeler:

Code: 
Sub snb()
   on error resume next
   For Each cl  In Sheets("DUMP").columns(1).specialcells(2)
     if cl.row> 2 then Sheets("OVERVIEW").columns(1).Find(cl, ,xlvalues , xlWhole).resize(,5)=cl.resize(,5).value
     if err.number<>0 then Sheets("OVERVIEW").cells(rows.count,1).end(xlup).offset(1).resize(,5)=cl.resize(,5).value
     err.clear
   Next
End Sub
 
Laatst bewerkt:
@Snb dat werkt alleen als de kolommen 1-op-1 matchen. Bovendien worden nieuwe regels niet correct toegevoegd.
 
Laatst bewerkt:
wampier zei:
Kleine aanpassing dan:

Code: 
Sub overboeken()
    For Each boek In Range(Sheets("DUMP").[a3], Sheets("DUMP").[a50000].End(xlUp))
        Set zoeken = Range(Sheets("OVERVIEW").[a3], Sheets("OVERVIEW").[a50000].End(xlUp)).Find(boek.Value, , , xlWhole)
        If Not zoeken Is Nothing Then
            With zoeken
                .Value = boek
                .Offset(0, 1) = boek.Offset(0, 1)
                '.Offset(0, 2) = boek.Offset(0, 2)
                If .Offset(0, 3) = "" Then
                   [B] .Offset(0, 3) = boek.Offset(0, 3)[/B]
                Else
                    .Offset(0, 4) = boek.Offset(0, 3)
                End If
                .Offset(0, 5) = boek.Offset(0, 4)
            End With
        Else
            With Sheets("OVERVIEW").[a50000].End(xlUp).Offset(1)
                .Value = boek
                .Offset(0, 1) = boek.Offset(0, 1)
                .Offset(0, 2) = boek.Offset(0, 2)
                .Offset(0, 3) = boek.Offset(0, 3)
                .Offset(0, 5) = boek.Offset(0, 4)
            End With
        End If
        
    Next boek
End Sub
Klik om te vergroten...

Nog een klein foutje ontdekt. Zo werkt hij naar behoren!
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan