Visual basic: Selecteren van cellen

[Batigoal80]

Via een macro wil ik een database vullen.
Eerst zoekt deze macro de cel in de eerste kolom de datum erbij , daarna moet hij verder gaan in de tweede kolom alleen begint hij dan weer bovenaan en dat moet niet:


Voorbeeld database
Datum
1-1-2008 Ochtend
1-1-2008 Middag
2-1-2008 Ochtend
2-1-2008 Middag
3-1-2008 Ochtend
3-1-2008 Middag

Dit is de code die ik nu heb

Sub VoorbeeldDoUntil()
    
    Dim strNaam As String
    Dim strWaarde As String
    Dim j As Integer
    
    j = 1
    strNaam = Range("j1").Value
    strWaarde = Range("A1").Value
    Range("A1").Select
    
    Do Until strWaarde = strNaam
        Cells(j, 1).Select
        strWaarde = Selection.Value
        Application.Wait (Now + TimeValue("0:00:01"))
        j = j + 1
    Loop
    
    Selection.End(xlToRight).Select
    Application.Wait (Now + TimeValue("0:00:01"))
    
    j = 1
    strNaam = Range("j2").Value
    strWaarde = Range("B1").Value
    Application.Wait (Now + TimeValue("0:00:01"))
    
    Do Until strWaarde = strNaam
        [COLOR="Red"]Cells(j, 2).Select[/COLOR]
        strWaarde = Selection.Value
        j = j + 1
    Application.Wait (Now + TimeValue("0:00:01"))
    
    Loop
    
End Sub

Waarschijnlijk zit de fout in het rood aangegeven gedeelte waar hij de 2e kolom selecteerd. Ik weet van tevoren natuurlijk niet op welke regel hij moet inspringen alleen dat hij verder naar beneden moet gaan zoeken.

Ik hoop dat iemand mij kan helpen!

Wouter van den Berg

 

[Ginger]

Batigoal80, Wat wil je met deze code bereiken??? Je doet volgens mij helemaal niets met de gevonden cel(len). Plaats ff je werkmap (gezipt) dan kunnen we de code met je naspelen.
Verwijder in iedergeval al die 'application.wait' regels. Die zijn nodeloos je code aan het vertragen.

Groet, Leo

 

[Batigoal80]

Map

Ik heb er een rar van gemaakt.Vanwege bedrijfsgeheim heb ik een testbestand toegevoegd.

Het is de bedoeling dat de getallen 1,2,3,4,5 op de juiste plek in de database terechtkomen. Ik heb de seconden toegevoegd om te achterhalen tot waar het goed gaat.

Via de invulvelden in kolom J moet de macro herkennen waar het in de kolom komt te staan.

Bedankt alvast

Wouter van den Berg

 

[Ginger]

Batigoal80, Dit codeblokje zou moeten doen wat je wilt...

Sub PlaatsWaarden()
Dim dFindDate As Date
Dim lFoundDate As Long, lFoundShift As Long
Dim i As Integer
Dim sFoundShift As String
      
    dFindDate = Range("J1").Value
    sFoundShift = Range("J2").Value
      
    lFoundDate = Range("A:A").Find(What:=dFindDate, After:=Range("A1"), LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Row
    
    i = 0
    Do Until Cells(lFoundDate + i, 2).Value = sFoundShift
        lFoundShift = Cells(lFoundDate + i + 1, 2).Row
        i = i + 1
    Loop
    
    Range("C1:G1").Copy Cells(lFoundShift, 3)

End Sub

Met het 'Find' wordt er in kolom A gezocht naar de juiste datum (de 1e die er gevonden kan worden). Vervolgens ga je op het gevonden punt een lus in (omdat je dat graag wilde) in kolom B. Hier wordt gezocht naar de ploeg. Bij het vinden wordt de lus verlaten en wordt direct de range C1:G1 naar de juiste plek gecopieerd.

Let wel op! Er is géén enkele vorm van foutafhandeling! Bijvoorbeeld: wat als de gezochte datum niet bestaat; wat als de ploegomschrijving fout wordt ingegeven (oneindige lus!); wat als er al data staat op de plek waar de nieuwe data moet komen; enzovoorts (zelf verder bedenken!:thumb

Groet, Leo

 

[Batigoal80]

Bedankt

Dit is geweldig. Het voorkomen van foute invoer doe ik door middel van validatie. Hierbij komt een bericht dat de invoer enkel bepaalde ingaven mag kennen.

Ik zou nog veel meer willen weten van Excel. Al dit soort zaken dus. Is er een goed boek of iets wat mij hierbij zou kunnen helpen?
En doe je dit voor je hobby Ginger? Of krijg je hier ook wat voor?

Ok deze vraag is dus weer opgelost!

Berdankt!

Wouter

 

[Finch]

Is er een goed boek of iets wat mij hierbij zou kunnen helpen?

Zou een sticky met wat boeken (evt. onderverdeeld in categoriën, leercurves of iets dergelijks) geen idee zijn? Die vraag komt regelmatig terug vandaar.

Ook een opsomming van goede Excel sites is misschien niet slecht.

 

[Batigoal80]

Toch nog niet opgelost

Ik kom nog een fout tegen. op zich werkt het prima alleen kan ik niets wegschrijven op de ochtendploeg. Schijnbaar kan hij het niet op het eerste veld naast de gevonden datum!

 

[Ginger]

Batigoal80, Hmmm... 't was gisteren duidelijk laat toen ik die code nog ff maakte...

Het zit 'm in de lus die ik niet goed kreeg en vervolgens maar voor deze optie koos

lFoundShift = Cells(lFoundDate + i [COLOR="Blue"]+ 1[/COLOR], 2).Row

Dit had ik gedaan omdat er anders een fout regelnummer teruggegeven werd. Ik reageer nu ff in m'n pauze maar heb verder geen tijd om hier in te duiken. Als er niemand anders reageert zal ik vanavond ff kijken. (en anders heb je dus je oplossing al sneller)

Groet, Leo

 

[Batigoal80]

Bedankt alvast.

Tevens is op mijn testbestand database en het controleveld op 1 blad op het orgineel is het zoals in dit bestandje.

 

[Batigoal80]

Deze werkt inderdaag maar hoe kan ik hem laten werken bij voorbeeld "TEST1" waarbij ik 2 verschillende tabbladen gebruik.

Ik hoop dat ik niet al te lastig ben. Probeer het zelf te veranderen maar het lukt me niet!

Groet Wouter


zojuist stond hier nog een reactie boven, die is waarschijlijk verwijderd. in deze reactie stond de juiste oplossing voor bestand "TEST"

 

[Vinnie82]

Sub PlaatsWaarden()
Dim dFindDate As Date
Dim lFoundDate As Long, lFoundShift As Long
Dim i As Integer
Dim sFoundShift As String
      
    dFindDate = Range("J1").Value
    sFoundShift = Range("J2").Value
      
    lFoundDate = Range("A:A").Find(What:=dFindDate, After:=Range("A1"), LookIn:=xlValues, LookAt _
        :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Row
    
    i = 0
    lFoundShift = Cells(lFoundDate + i, 2).Row
    Do Until Cells(lFoundDate + i, 2).Value = sFoundShift
        i = i + 1
        lFoundShift = Cells(lFoundDate + i, 2).Row
    Loop
    
    Range("C1:G1").Copy Cells(lFoundShift, 3)
    
End Sub

Dit is volgens mij de code die het moet zijn. Werkt ook prima met de ochtendploeg! (Is trouwens alleen als je op het eerste tabblad blijft werken, ik kan er even niet meer op komen hoe je die ook alweer moet aanroepen vanaf een ander tabblad)
Heb ik nog een vraagje. Waarom selecteer je telkens cellen voor je er een bewerking op uitvoert? Je kunt ook gewoon de bewerking uitvoeren op deze manier namelijk: Range("J1:J2").ClearContents
Het scheelt nu niet veel code, maar bij grotere macro's kan het behoorlijk wat schelen.

 

[Finch]

Volgens mij gaat dit sneller werken wanneer je met autofilters werkt. Ik heb daarvoor even de code aangepast.

[FONT="Courier New"]Sub Filteren()
Dim dFindDate As Date
Dim sFoundShift As String
Dim rngData As Range
Dim lngRow As Long
      
dFindDate = Range("J1").Value
sFoundShift = Range("J2").Value

Set rngData = Range("A1:B1", Range("A1").End(xlDown))
rngData.Select

rngData.AutoFilter 1, dFindDate
rngData.AutoFilter 2, sFoundShift

If rngData.SpecialCells(xlCellTypeVisible).Count <> 4 Then 'indien dit 4 cellen zijn is er maar 1 rij gevonden, anders meerdere en dan foutmelding
    MsgBox "Verkeerd aantal rijen"
Else
    lngRow = rngData.SpecialCells(xlCellTypeVisible).End(xlDown).Row
    Range("C1:G1").Copy Cells(lngRow, 3)
End If
ActiveSheet.AutoFilterMode = False
Range("a1").Select
End Sub[/FONT]

Zet wel nog even volgende waarde in A1 en B1:

A1=Datum
B1=Ploeg

 

[Batigoal80]

Ik kom echt geen wijs uit die VBA-taal heb het eerste boek al besteld morgen binnen!
Normaal werk ik niet met VBA enkel macro opnemen, maar dat gaat in deze niet natuurlijk.

Zou iemand een blik kunnen werpen op bestand "TEST1", want ik kan de code die zeker werkt in bestand "TEST" niet ombouwen naar een code die werkt in bestand "TEST1".

Gr Wouter

 

[Finch]

Doet deze code wat je wilt?

[FONT="Courier New"]Sub Filteren()
Dim dFindDate As Date
Dim sFoundShift As String
Dim rngData As Range
Dim lngRow As Long
Dim ws1 As String
Dim ws2 As String
Dim i As Long

wsInvoer = "Blad1"
wsdata = "Blad2"

dFindDate = Sheets(wsInvoer).Range("J1").Value
sFoundShift = Sheets(wsInvoer).Range("J2").Value

Set rngData = Sheets(wsdata).Range("A1:B1", Sheets(wsdata).Range("A1").End(xlDown))

rngData.AutoFilter 1, dFindDate
rngData.AutoFilter 2, sFoundShift

If rngData.SpecialCells(xlCellTypeVisible).Count <> 4 Then 'indien dit 4 cellen zijn is er maar 1 rij gevonden, anders meerdere en dan foutmelding
    MsgBox "Verkeerd aantal rijen"
Else
    lngRow = rngData.SpecialCells(xlCellTypeVisible).End(xlDown).Row
    For i = 1 To 5
        Sheets(wsdata).Cells(lngRow, 2 + i) = Sheets(wsInvoer).Cells(1 + i, 2)
    Next i
End If
Sheets(wsdata).AutoFilterMode = False
Range("A1").Select
End Sub[/FONT]

Wel nog even op Blad2 in A1 en B1 volgende tekst zetten:

A1=Datum
B1=Ploeg

 

[Batigoal80]

Yesssssss,

Dank jullie wel allemaal!

Vraag volledig afgerond~!!!!!!:thumb::thumb:

 

[Finch]

Zie net dat ik een eerder declaratie van variabelen niet heb aangepast. Gelieve voor de volledigheid volgende nog te wijzigen

Dim ws1 As String
Dim ws2 As String

veranderen naar

Dim wsInvoer As String
Dim wsData As String

Het gaat niet aan de werking veranderen, maar dit is correcter.