rijen van lijst naar verschillende tabbladen

[Hendrik86]

Hallo allemaal,

Ik ben een gebruiker van de basisfuncties van Excel en wou graag weten of het volgende kan, en zoja op welke manier:

Ik heb een lijst (zie bijlage), bv. met verschillende klanten en hun facturen, geïmporteerd vanuit een ander programma.

Ik voeg voor de onbetaalde facturen nog een extra kolom (C) toe, om ze te kunnen categoriseren volgens reden van niet-betaling. Periodiek laat ik mijn boekhoudprogramma een nieuwe Excellijst genereren en werk ik mijn bestand bij (bv. rijen (dus facturen) verwijderen of bedragen wijzigen). Om dit werk makkelijk en snel te kunnen voltooien, wil ik dus een overzicht van alle facturen behouden in één tabblad. Maar nu zou ik ook nog de facturen per categorie willen weergeven in aparte tabbladen. Bv. een tabblad met alle facturen uit de categorie "betwist", dat dan rij 2 (factuur 2011/1) bevat.

Is het dan ook mogelijk dat deze gegevens op aparte tabbladen automatisch worden bijgewerkt? Als ik bv. het betaald bedrag van de factuur in rij 2 in het tabblad "alles" aanpas, wordt deze cel dan ook bijgewerkt in het tabblad waarin deze rij staat?

Alvast bedankt!

Edit: Ik had mijn vraag ook op een ander forum gepost.

 

[Wigi]

Ik zie persoonlijk weinig voordelen van het opknippen van een tabel in stukken. Hetgeen jij vraagt is al zo vaak behandeld gewest dat ik verwijs naar Ozgrid:

http://www.ozgrid.com/VBA/item-worksheets.htm

Wil je de individuele tabbladen updaten, draai de macro dan nogmaals.

 

[Hendrik86]

Ik krijg steeds een foutmelding (Syntaxisfout/Compileerfout) bij de regel

rRange.AdvancedFilter xlFilterCopy, , _

Ik heb eigenlijk nog niet met macro's gewerkt, dus doe ik misschien iets verkeerd? Ik vind op Internet vooral handleidingen om zelf macro's op te nemen, maar niet hoe ik deze code kan gebruiken (kopiëren en plakken).

 

[Wigi]

Post hier dan de hele code eens, tussen

 tags aub.

 

[Hendrik86]

Sub PagesByDescription()

Dim rRange As Range, rCell As Range

Dim wSheet As Worksheet

Dim wSheetStart As Worksheet

Dim strText As String



    Set wSheetStart = ActiveSheet

    wSheetStart.AutoFilterMode = False

    'Set a range variable to the correct item column

    Set rRange = Range("C1", Range("C65536").End(xlUp))

    

        'Delete any sheet called "UniqueList"

        'Turn off run time errors & delete alert

        On Error Resume Next

        Application.DisplayAlerts = False

        Worksheets("UniqueList").Delete

        

        'Add a sheet called "UniqueList"

        Worksheets.Add().Name = "UniqueList"

        

           'Filter the Set range so only a unique list is created

            With Worksheets("UniqueList")

                rRange.AdvancedFilter xlFilterCopy, , _

                 Worksheets("UniqueList").Range("C1"), True

                 

                 'Set a range variable to the unique list, less the heading.

                 Set rRange = .Range("C2", .Range("C65536").End(xlUp))

            End With

            

            On Error Resume Next

            With wSheetStart 

            	For Each rCell In rRange

                  strText = rCell

                 .Range("C1").AutoFilter 1, strText

                    Worksheets(strText).Delete

                    'Add a sheet named as content of rCell

                    Worksheets.Add().Name = strText

                    'Copy the visible filtered range _

                    (default of Copy Method) and leave hidden rows

                    .UsedRange.Copy Destination:=ActiveSheet.Range("C1")

                    ActiveSheet.Cells.Columns.AutoFit

                Next rCell

            End With

            

        With wSheetStart 

        	.AutoFilterMode = False

            .Activate

        End With

        

        On Error GoTo 0

        Application.DisplayAlerts = True

End Sub

Dit is de code van de site die je doorlinkte, alleen heb ik wijzigingen aangebracht van kolom A naar kolom C.

 

[HSV]

Kun je met deze code uit de voeten?

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim iWS As Integer, cl As Range
  If Not Intersect(Target, Columns(6)) Is Nothing Then
   For iWS = 2 To Sheets.Count
    For Each cl In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
      If cl > 0 And cl.Offset(, 2) = Sheets(iWS).Name Then
        Sheets(iWS).UsedRange.ClearContents
          Sheets(iWS).Cells(Rows.Count, 1).End(xlUp).Offset(1) = cl
         End If
        Next cl
       Sheets(iWS).Range("A1") = "Factuurnr(s) " & Sheets(iWS).Name
      Sheets(iWS).Columns(1).AutoFit
    Next iWS
  End If
End Sub

Of misschien beter.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim iWS As Integer, cl As Range
  If Not Intersect(Target, Columns(6)) Is Nothing Then
   For iWS = 2 To Sheets.Count
    For Each cl In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    With Sheets(iWS)
      If cl > 0 And cl.Offset(, 2) = .Name Then
        .UsedRange.ClearContents
          .Cells(.Rows.Count, 1).End(xlUp).Offset(1).EntireRow.Value = cl.EntireRow.Value
         End If
       End With
     Next cl
        With Sheets(iWS)
         .Range("A1") = "Factuurnr(s) " & .Name
         .Range("B1").Resize(, 7).Value = Range("B1").Resize(, 7).Value
         .Columns("A:H").AutoFit
      End With
    Next iWS
  End If
End Sub

 

[Hendrik86]

Alvast bedankt voor de code, maar het lukt me niet om de code op een correcte manier in te voegen. Wat rondzoeken op internet heeft me nog niet veel wijzer gemaakt..
Kan ik ergens vinden hoe ik dit precies doe, want ik ben hier niet vertrouwd mee?

 

[HSV]

Druk Alt+F11
Dubbelklik aan linkerkant op tabblad 'Alles'.
Zet de onderstaande code (iets gewijzigd t.o.v. vorige) in het grote witte vlak.
Sluiten met Alt+F11 of Alt+Q.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim iWS As Integer, cl As Range
  If Not Intersect(Target, Columns(6)) Is Nothing Then
   For iWS = 2 To Sheets.Count
   Sheets(iWS).UsedRange.ClearContents
    For Each cl In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row)
    With Sheets(iWS)
      If cl > 0 And cl.Offset(, 2) = .Name Then
        
          .Cells(.Rows.Count, 1).End(xlUp).Offset(1).EntireRow.Value = cl.EntireRow.Value
         End If
       End With
     Next cl
        With Sheets(iWS)
         .Range("A1") = "Factuurnr(s) " & .Name
         .Range("B1").Resize(, 7).Value = Range("B1").Resize(, 7).Value
         .Columns("A:H").AutoFit
      End With
    Next iWS
  End If
End Sub

Als je nu een bedrag veranderd in kolom F (betaald bedrag), worden de gegevens naar de desbetreffende bladen weggeschreven.

 

[Hendrik86]

heel erg bedankt!

 

[HSV]

heel erg bedankt!

Zou je de vraag nog als opgelost kunnen markeren Hendrik?

 

[Hendrik86]

ik wou nog weten wat ik in de code moet wijzigen indien ik nog een extra kolom wil toevoegen of sorteren op basis van een andere of nieuwe kolom

kan ik ook ergens meer uitleg vinden over deze code (de betekenis van de regels)?

 

[HSV]

Het ligt er aan waar je een kolom gaat invoegen.
Als het na kolom C is, dan resize( ,7) veranderen in Resize( ,8).

Zet deze code eens in je blad en de tekst die ik heb toegevoegd wordt in het groen weergegeven.

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim iWS As Integer, cl As Range
  If Not Intersect(Target, Columns(6)) Is Nothing Then 'als je iets in kolom F wijzigd.
   For iWS = 2 To Sheets.Count 'telt het aantal bladen in je workbook na het 2e werkblad.
   Sheets(iWS).UsedRange.ClearContents 'het gebruikte bereik wissen van die blad
    For Each cl In Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row) 'loopt de cellen bij langs
    With Sheets(iWS) 'blad 2 tot aantal bladen in je workbook
      If cl > 0 And cl.Offset(, 2) = .Name Then 'als cel > 0, en cel rechts 2 verderop is bladnaam dan doorgaan, anders stoppen
        
          .Cells(.Rows.Count, 1).End(xlUp).Offset(1).EntireRow.Value = cl.EntireRow.Value 'bij vorige regel waar, dan de gehele rij neer zetten in het blad waar het hoort op de eerste lege rij
         End If
       End With
     Next cl 'volgende cel
        With Sheets(iWS)
         .Range("A1") = "Factuurnr(s) " & .Name 'zet in cel A1 'factuurnr(s)' en het bladnaam neer
         .Range("B1").Resize(, 7).Value = Range("B1").Resize(, 7).Value 'elk blad krijgt dezelfde kopregel als blad 'Alles'
         .Columns("A:H").AutoFit 'kolommen A t/H op juiste breedte maken
      End With
    Next iWS 'volgend blad
  End If
End Sub