chronologische lijst creeren

[Dijk79]

Hallo,
Op het moment ben ik aan het afstuderen, als een klein onderdeel ervan wil ik een chronologisch lijst creeren. Ik heb het sheetje toegevoegd. Ben zelf al twee dagen bezig, maar het wil niet echt lukken in VB. en ben vandaag weer radeloos opnieuw begonnen.

Het gaat eigenlijk om het volgende:
in de sheet "vo" en "do" staan elk gegevens van bepaalde tekeningen die ik heb gemaakt waarbij ik eigenlijk een lijst wil maken in VB die bij het het tabblad "totaal" de gegevens onder elkaar opsomd. Het zou mooi zijn als dit via een knop kan waarbij de gegevens worden overgezet naar 'totaal' echter komt het ook voor dat een bepaalde tekening wijzigd en als ik dan op diezelfde knop zou drukken moeten de gegevens van alleen de gewijzigde tekenen weer onder de reeds gekopieerde cellen komen

de range die daarvoor nodig is (waarin de tekeningen staan) kan ook vrij lang worden, is dit nog te ondervangen?

in bijgevoegd excel sheet is een voorbeeld gegeven van o.a.de totaallijst en het VO DO tabblad hoe het resultaat eruit zou komen te zien

alvast heel erg bedankt

J.Dijk

 

[Demeter]

Ik denk dat je met de volgende code redelijk ver komt (nog even tijd vrij kunnen maken):

Sub overzetten()
Dim c As Range
Dim laatsteregelVO, laatsteregelDO, laatsteregelTO As Long
Dim legeregelTO As Long
Dim x, teller As Long

laatsteregel1 = Sheets("VO").Range("B65536").End(xlUp).Row
laatsteregel2 = Sheets("DO").Range("B65536").End(xlUp).Row
laatsteregelTO = Sheets("TOTAAL").Range("A65536").End(xlUp).Row
teller = 0

    Application.ScreenUpdating = False

    For x = 1 To 2
        For Each c In Sheets(x).Range("B2:B" & laatsteregel1)
            If c <> "" Then
                With Sheets("TOTAAL")
                    Set zoeknaam = .Range("A2:A" & laatsteregelTO).Find(c.Value)
                    If Not zoeknaam Is Nothing Then
                        If .Range("F" & zoeknaam.Row) <> c.Offset(, 4) Then
                            Set zoeknaamII = .Range("E2:E" & laatsteregelTO).Find(c.Offset(, 4).Value)
                            If zoeknaamII Is Nothing Then
                                legeregelTO = .Range("A65536").End(xlUp).Row + 1
                                c.Resize(1, 11).Copy .Range("A" & legeregelTO)
                                teller = teller + 1
                            End If
                        End If
                    Else
                        legeregelTO = .Range("A65536").End(xlUp).Row + 1
                        c.Resize(1, 11).Copy .Range("A" & legeregelTO)
                        teller = teller + 1
                    End If
                End With
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    If teller <> 0 Then
        MsgBox "Er is/zijn " & teller & " tekeningen overgezet!"
    Else
        MsgBox "Er zijn geen aangepaste tekeningen gevonden!"
    End If

End Sub

Succes

 

[Jamez]

Ik denk dat je met de volgende code redelijk ver komt (nog even tijd vrij kunnen maken):

Sub overzetten()
Dim c As Range
Dim laatsteregelVO, laatsteregelDO, laatsteregelTO As Long
Dim legeregelTO As Long
Dim x, teller As Long

laatsteregel1 = Sheets("VO").Range("B65536").End(xlUp).Row
laatsteregel2 = Sheets("DO").Range("B65536").End(xlUp).Row
laatsteregelTO = Sheets("TOTAAL").Range("A65536").End(xlUp).Row
teller = 0

    Application.ScreenUpdating = False

    For x = 1 To 2
        For Each c In Sheets(x).Range("B2:B" & laatsteregel1)
            If c <> "" Then
                With Sheets("TOTAAL")
                    Set zoeknaam = .Range("A2:A" & laatsteregelTO).Find(c.Value)
                    If Not zoeknaam Is Nothing Then
                        If .Range("F" & zoeknaam.Row) <> c.Offset(, 4) Then
                            Set zoeknaamII = .Range("E2:E" & laatsteregelTO).Find(c.Offset(, 4).Value)
                            If zoeknaamII Is Nothing Then
                                legeregelTO = .Range("A65536").End(xlUp).Row + 1
                                c.Resize(1, 11).Copy .Range("A" & legeregelTO)
                                teller = teller + 1
                            End If
                        End If
                    Else
                        legeregelTO = .Range("A65536").End(xlUp).Row + 1
                        c.Resize(1, 11).Copy .Range("A" & legeregelTO)
                        teller = teller + 1
                    End If
                End With
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    If teller <> 0 Then
        MsgBox "Er is/zijn " & teller & " tekeningen overgezet!"
    Else
        MsgBox "Er zijn geen aangepaste tekeningen gevonden!"
    End If

End Sub

Succes

Beste Ferenc,
Super gaaf! het werkt echt goed. Waar het om neer komt is dat je op een gegeven moment naar de wijzigingen laat zoeken en die naar het blad 'totaal' kopieerd. Ben er echt heel blij mee!
Ondanks mn eigen gekluns ben ik erg enthousiast geworden over die soort hoogstandjes, heb jij toevallig nog tips hoe je dit het beste kunt leren? heb je bepaalde boeken gekocht? of blijven proberen?

groeten

J.Dijk

 

[Wigi]

Ondanks mn eigen gekluns ben ik erg enthousiast geworden over die soort hoogstandjes, heb jij toevallig nog tips hoe je dit het beste kunt leren? heb je bepaalde boeken gekocht? of blijven proberen?

Op het forum hebben al vaak van zulke dingen gestaan. Ik heb er in ieder geval al meer dan eens op geantwoord. Zoek daar eens eerst naar.

 

[Jamez]

Op het forum hebben al vaak van zulke dingen gestaan. Ik heb er in ieder geval al meer dan eens op geantwoord. Zoek daar eens eerst naar.

okay, ik zal nog eens nader zoeken

gr. Jamez

 

[Demeter]

Ten eerste is het internet een mooi vergaarbak van kennis, waar je wel moet weten wat je wil vinden. Hiervoor zijn de verschillende fora wel handig om je in de juiste richting te duwen. Kijk ook vooral naar de websites van de mede poster (Wigi, Luc Hendrixcks, etc...).

Maar natuurlijk heb je een naslagwerk nodig welke direct te raad plegen is. vooral in de verloeren minuutjes in het kleine kamertje .
Kijk eens naar J. Walkenbach boeken. Maar keuze van een boek valt of staat natuurlijk voorla bij je eigen kennis nivo en de richting waarin je op wilt .

Aangezien je de code al direct kan ontcijferen ben je al geen leek/beginner meer dus hier zal je ook zeker wel uit geraken (om het in mijn beste belgisch te zeggen ).

ps.
Graag gedaan, zo kom ik ook nog mijn laatste dagen door bij mijn huidige werkgever.

 

[Dijk79]

Beste Demeter,
Het werkt echt goed. Is het echter ook mogelijk om binnen de gegeven vb code het probleem te ondervangen dat wanneer een extra sheet wordt aangemaakt, dat de code dan hierop ook werkt?

of

Ik zou me voor kunnen stellen dat de code aan een sheet wordt gehangen en dat wanneer er een nieuwe sheet nodig is, dat een bestaande wordt gekopieerd. Is dit mogelijk binnen VB?

b.v.d.

 

[Demeter]

Aantal sheets wat kan worden doorlopen kan je mbv een sheets.count formule doen.
Als je altijd je totaal blad als laatste laat staan dan kan je onderbouwen met Sheets.Count -1 (aantal totale bladen - de laatste).

Sub overzetten()
Dim c As Range
Dim laatsteregelTO, legeregelTO As Long
Dim x, teller As Long

laatsteregelTO = Sheets("TOTAAL").Range("A65536").End(xlUp).Row
teller = 0

    Application.ScreenUpdating = False

    For x = 1 To Sheets.Count - 1
        For Each c In Sheets(x).Range("B2:B" & Sheets(x).Range("B65536").End(xlUp).Row)
            If c <> "" Then
                With Sheets("TOTAAL")
                    Set zoeknaam = .Range("A2:A" & laatsteregelTO).Find(c.Value)
                    If Not zoeknaam Is Nothing Then
                        If .Range("F" & zoeknaam.Row) <> c.Offset(, 4) Then
                            Set zoeknaamII = .Range("E2:E" & laatsteregelTO).Find(c.Offset(, 4).Value)
                            If zoeknaamII Is Nothing Then
                                legeregelTO = .Range("A65536").End(xlUp).Row + 1
                                c.Resize(1, 11).Copy .Range("A" & legeregelTO)
                                teller = teller + 1
                            End If
                        End If
                    Else
                        legeregelTO = .Range("A65536").End(xlUp).Row + 1
                        c.Resize(1, 11).Copy .Range("A" & legeregelTO)
                        teller = teller + 1
                    End If
                End With
            End If
        Next
    Next
    
    Application.ScreenUpdating = True
    
    If teller <> 0 Then
        MsgBox "Er is/zijn " & teller & " tekeningen overgezet!"
    Else
        MsgBox "Er zijn geen aangepaste tekeningen gevonden!"
    End If

End Sub

Tevens heb ik de code iets aangepast zodat de laatsteregels nu direct vanuit de loop worden bekeken.

Voor vraag twee zou je alleen de loop waarin je werkbladen worden doorlopen weg moeten halen en dan zou de code achter ieder werkblad geplakt kunnen worden. Aleen als je de code dan zou willen aanpassen moet je deze weer voor ieder blad gaan aanpassen .