• Privacywetgeving
    Het is bij Helpmij.nl niet toegestaan om persoonsgegevens in een voorbeeld te plaatsen. Alle voorbeelden die persoonsgegevens bevatten zullen zonder opgaaf van reden verwijderd worden. In de vraag zal specifiek vermeld moeten worden dat het om fictieve namen gaat.

Projectgegevens in draaitabel

Status
Niet open voor verdere reacties.
K

keesbl

Gebruiker
Lid geworden
8 nov 2008
Berichten
694
Experts,

Ik werk met Excel 2007.
Ik heb een bestand (zie bijlage), waarin ik projectgegevens bijhoud, met twee tabbladen, gegevens, draaitabel. Het lukt mij niet om een aantal zaken te regelen wat betreft de weergaven van de draaitabel. Wat ik wil heb ik op het tabblad Draaitabel aangegeven. Het gaat erom dat ik wel de juiste gegevens in de draaitabel krijg, maar ik moet bij de weergave van een ander kavelnummer steeds een aantal dezelfde handelingen en instellingen doen. Dat moet eenvoudiger kunnen, denk ik.
De ellende is dat ik denk dat het via VBA moet, en daar heb ik dus helemaal geen verstand van.
Wie kan mij helpen?

Kees
 

Bijlagen

  • Probleem draaitabel.xlsx
    54,5 KB · Weergaven: 45
dit is geen werk voor een draaitabel maar voor een klein macrootje
 

Bijlagen

  • Probleem%20draaitabel(1).rar
    39,8 KB · Weergaven: 36
Hallo Cow18,

Dit is wat ik bedoel! Dank!

In de categorie-regel, de donkergrijze, staan in kolom C en D nog waarden. Kunnen die nog verwijderd worden? (Op het blad Gegevens moeten die wel zichtbaar blijven!) En E3 en F3 mogen ook leeg blijven.

Wat wel mooi zou zijn is dat een paar rijen onder de laatst gevulde rij in kolom D de totaalprijs zou komen te staan.

Kan dit makkelijk aangepast worden?
Is er ook een afdrukbereik aan te koppelen, aan het variabele aantal rijen?

Kees
 
Laatst bewerkt:
hierbij de nieuwe macro met de gevraagde aanpassingen
eigenlijk verandert het printbereik niet omdat je rijen verbergt, dus wijzigen de rijen niet zolang je in "gegevens" niets verandert, maar ik heb hem toch mee opgenomen
Code: 
Sub EenKavel()
  Dim i As Integer, KavelNr As String, c As Range
  KavelNr = CStr(Sheets("Kavel").Range("A1"))              'gewenste kavelnummer
  With Sheets("Kavel")
    .UsedRange.Offset(1).Delete                            'alles behalve rij 1 wissen, drastischer dan Clear om straks printarea juist te krijgen
    .UsedRange.Offset(, 1).Delete                          'alles behalve kolom 1 wissen
    .AutoFilterMode = False                                'eventuele filter uitzetten
  End With

  With Sheets("gegevens")
    For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column  'loop alle kolommen in gegevens af
      .Columns(i).Hidden = (i > 2 And .Cells(1, i).Value <> KavelNr)  'verberg de ongewenste
    Next
    .UsedRange.SpecialCells(xlVisible).Copy
    Sheets("Kavel").Range("A3").PasteSpecial xlFormats
    Sheets("Kavel").Range("A3").PasteSpecial xlValues      'kopieer zichtbaar gedeelte naar ander tabblad, enkel opmaak en inhoud !
    .Rows(1).EntireColumn.Hidden = False                   'alles weer zichtbaar maken
  End With

  With Sheets("Kavel")
    .Range("A3").CurrentRegion.Columns(3).Copy .Range("D3")  'opmaak 3e kolom naar 4e kolom kopieren
    For Each c In .Range("A3").CurrentRegion.Columns(2).Cells
      If c.Interior.ColorIndex > 0 And c.Value = "" Then c.Offset(, 1) = IIf(c.Offset(, 1).Value = 0, "", " .")  'verwijder getal in de C-kolom als achtegrond niet wit is en er niets in B en iets in die C stond
    Next
    .Range("A3").CurrentRegion.Columns(3).Offset(, 1).FormulaR1C1 = "=IF(COUNT(RC[-2]:RC[-1])=2,RC[-2]*RC[-1],"""")"  'formule zetten in 4e kolom
    .Range("D3") = "prijskaartje"                          'title 4e kolom
    .Range("A3").CurrentRegion.Columns(3).AutoFilter 1, "<>"  'filter op aantal >0
    i = Range("A3").CurrentRegion.Columns(1).Cells.Count + 1  'bepaal hoever onder tabel je totaal komt (getal dat je erbij telt = aantal lege rijen)
    .Range("A3").Offset(i) = "totaal prijskaartje is :"
    .Range("D3").Offset(i) = WorksheetFunction.Sum(.Range("A3").CurrentRegion.Columns(4))  'totaalprijs
    With .Rows(Range("A3").Offset(i).Row).Font             'een beetje opmaak voor die totaalrij
      .FontStyle = "Vet Cursief"
      .Underline = xlUnderlineStyleDouble
    End With
    .Columns("D").NumberFormat = "#,##0.00 $"              'financiele opmaak voor de D-kolom
    .Range("A3:F3").Cells.EntireColumn.AutoFit             'kolombreedte aanpassen
    .PageSetup.PrintArea = .UsedRange.Address              'normaal blijft printbereik altijd gelijk, maar anders ...
    MsgBox .UsedRange.Address
  End With
  Application.CutCopyMode = False
  ActiveCell.Select
End Sub
 
Hallo Cow18,

Dank voor je reactie.
Als ik nu een kavelnummer kies, krijg ik de vraag of ik het hele blad wil wissen. Als ik dit doe, dan krijg ik de juiste gegevens, maar nadat de macro is uitgevoerd, krijg ik nog een venstertje met een celbereik erin, van $A$1:$D$160.
Dit venstertje kan ik gewoon wegklikken.
Als ik daarna de gegevens van een volgend kavel wil zien, krijg ik weer de vraag of ik het hele blad wil wissen, dat doe ik, krijg de gegevens van de kavel. Maar daarna krijg ik in rij 1 de grijze balk met de categorie, de keuzerij om het kavel te kiezen is dan weg.

Als ik in het venster met de vraag om het hele blad te verwijderen op annuleren klik, krijg ik die vraag nog een keer, als ik weer annuleer, gaat het wel goed, en blijft de rij waarin ik het kavel kan kiezen wel in beeld.
Kunnen die venstertjes nog weg?

Als ik 10 rijen helemaal bovenin en onderaan wil invoegen voor algemene projectgegevens, moet dan de macro ook aangepast worden, of wordt die automatisch aangepast? Hoe kan ik dat doen?

Dank voor alle moeite

Kees
 
Laatst bewerkt:
Hallo Cow18,

Het probleem van de ongewenste meldingen heb ik opgelost met een ' voor de betreffende regel in de macro.
Wat betreft de lege rijen onder het overzicht, daar kan ik gewoon gegevens zetten. Alleen wil ik nog die 10 lege rijen boven het overzicht.

Kees
 
bovenin staan 2 parameters, de cel vanaf waar je wenst de tabel te starten, hier A10 en het aantal rijen die je nog vrij wilt hebben onder het prijskaartje, die kan je vrij aanpassen.
Misschien is alles leegmaken bovenin de module niet helemaal netjes, ik weet niet of er anders belangrijke dingen staan in dat werkblad ?
Code: 
Option Explicit
Const Begin    As String = "A10"                           'naar hier wens je die tabel te schrijven
Const ExtraLijnen As Integer = 10                          'zoveel extra lijnen onderin

Sub EenKavel()
  Dim i As Integer, KavelNr As String, c As Range
  KavelNr = CStr(Sheets("Kavel").Range("A1"))              'gewenste kavelnummer
  With Sheets("Kavel")
    .AutoFilterMode = False                                'eventuele filter uitzetten
    .UsedRange.Offset(1).Clear                             'alles behalve 1e rij leegmaken
    .UsedRange.Offset(, 1).Clear                           'alles behalve 1e kolom leegmaken
  End With

  With Sheets("gegevens")
    For i = 1 To .Cells(1, Columns.Count).End(xlToLeft).Column  'loop alle kolommen in gegevens af
      .Columns(i).Hidden = (i > 2 And .Cells(1, i).Value <> KavelNr)  'verberg de ongewenste
    Next
    .UsedRange.SpecialCells(xlVisible).Copy
    Sheets("Kavel").Range(Begin).PasteSpecial xlFormats
    Sheets("Kavel").Range(Begin).PasteSpecial xlValues     'kopieer zichtbaar gedeelte naar ander tabblad, enkel opmaak en inhoud !
    .Rows(1).EntireColumn.Hidden = False                   'alles weer zichtbaar maken
  End With

  With Sheets("Kavel")
    .Range(Begin).CurrentRegion.Columns(3).Copy .Range(Begin).Offset(, 3)  'opmaak 3e kolom naar 4e kolom kopieren
    For Each c In .Range(Begin).CurrentRegion.Columns(2).Cells
      If c.Interior.ColorIndex > 0 And c.Value = "" Then c.Offset(, 1) = IIf(c.Offset(, 1).Value = 0, "", " .")  'verwijder getal in de C-kolom als achtegrond niet wit is en er niets in B en iets in die C stond
    Next
    .Range(Begin).CurrentRegion.Columns(3).Offset(, 1).FormulaR1C1 = "=IF(COUNT(RC[-2]:RC[-1])=2,RC[-2]*RC[-1],"""")"  'formule zetten in 4e kolom
    .Range(Begin).Offset(, 3) = "prijskaartje"             'title 4e kolom
    .Range(Begin).CurrentRegion.Columns(3).AutoFilter 1, "<>"  'filter op aantal >0
    i = Range(Begin).CurrentRegion.Columns(1).Cells.Count + 1  'bepaal hoever onder tabel je totaal komt (getal dat je erbij telt = aantal lege rijen)
    .Range(Begin).Offset(i) = "totaal prijskaartje is :"
    .Range(Begin).Offset(i, 3) = WorksheetFunction.Sum(.Range(Begin).CurrentRegion.Columns(4))  'totaalprijs
    With .Rows(Range(Begin).Offset(i).Row).Font            'een beetje opmaak voor die totaalrij
      .FontStyle = "Vet Cursief"
      .Underline = xlUnderlineStyleDouble
    End With
    .Columns("D").NumberFormat = "#,##0.00 $"              'financiele opmaak voor de D-kolom
    .Range(Begin).Resize(1, 6).Cells.EntireColumn.AutoFit  'kolombreedte aanpassen
    .PageSetup.PrintArea = Range("A1:" & .Range(Begin).Offset(i + ExtraLijnen, 3).Address).Address  'normaal blijft printbereik altijd gelijk, maar anders ...
    .Range(.PageSetup.PrintArea).Rows(1).EntireColumn.AutoFit
  End With
  Application.CutCopyMode = False
  ActiveCell.Select
End Sub
 
Hallo Cow18,

Volgens mij werkt alles nu zoals ik het hebben wil! Ik heb zelfs een paar regeltjes code toegevoegd om de koppen boven het overzicht te centreren en voor de opmaak van de financiele cellen. En ik heb informatie opgevraagd bij een opleidingsinstelling voor een beginnerscursus VBA.

Ontzettend bedankt!

Kees
 
Hallo Cow,

We werken nu een poos met bovenstaande code.
Wat ik nog graag zou willen is het volgende:
Ik wil het werkblad Gegevens en Kavel beveiligen, zodat formules niet veranderd kunnen worden. Maar dan werkt de macro niet meer.
Is het mogelijk om de bladen te beveiligen en als de macro uitgevoerd wordt, de beveiliging er even af te halen, en nadat de macro is uitgevoerd, de beveiliging er weer op zetten?

Alvast bedankt!

Kees
 
je moet zelf de cellen bepalen die vergrendeld moeten worden, maar eens je dat gedaan hebt en he hebt de macro beveiligd, voorlopig eventjes zonder paswoord, dan laat je 1 keer deze macro lopen. Die geeft de macros toegang, zelfs als het blad beveiligd is.
Wil je toch een paswoord gebruiken, doe de beveiliging nog een keer eraf en beveilig opnieuw met je paswoord. (zou anders ook in 1 keer gekund hebben)
Code: 
Sub MacrosMogenVeelMeer()
  With Sheets("Gegevens")
    .Unprotect
    .Protect userinterfaceonly:=True
  End With
  With Sheets("Kavel")
    .Unprotect
    .Protect userinterfaceonly:=True
  End With
End Sub
 
Veel dank Cow18

Maar waar plak ik je code in het bestand? In this workbook?

Kees
 
in een gewone module en dan 1 keer laten lopen.
lukt het niet, stuur dan eens de laatste versie, want zo te zien is er toch 1 en ander verandert
 
Hallo Cow18,

Als ik je code uitvoer, staan daarna de bladen Gegevens en Kavel beveiligd.
Het bijwerken van het blad Kavel gaat dan niet, eerst moet de beveiliging van het bald afgehaald worden.
Nu moet ik elke keer als ik het bestand open, je laatste code handmatig uitvoeren. Kan deze code (in module 4) niet in de code in module 1 verwerkt worden?
Ik stuur je het bestand, ontdaan van gevoelige informatie, mee.

Alvast bedankt!
Kees
 

Bijlagen

  • Overzicht opties.rar
    77,1 KB · Weergaven: 32
in die macro Eenkavel voeg je vooraan 2 regels toe om je 2 tabbladen de beveiliging weg te halen en helemaal op het einde schakel je de beveiliging weer in.
aanpassingen in het rood
Code: 
Sub EenKavel()
  Dim i As Integer, KavelNr As String, c As Range
  KavelNr = CStr(Sheets("Kavel").Range("A1"))              'gewenste kavelnummer

  [COLOR="red"]Sheets("Kavel").Unprotect
  Sheets("Gegevens").Unprotect[/COLOR]

  With Sheets("Kavel")
    .AutoFilterMode = False                                'eventuele filter uitzetten
    '.UsedRange.Offset(1).Clear                             'alles behalve 1e rij leegmaken
    '.UsedRange.Offset(, 1).Clear                           'alles behalve 1e kolom leegmaken
  End With

......... tussenliggend stuk


   Application.CutCopyMode = False
  Range("A1").Select                                       'Naar cel A1 gaan

 [COLOR="red"] Sheets("Kavel").Protect
  Sheets("Gegevens").Protect[/COLOR] 
 'ActiveCell.Select
End Sub
 
Hallo Cow18,

Ik had zelf ook al zitten stoeien regels toevoegen in de macro die de beveiliging opheffen en later weer de werkbladen beveiligden. Maar dat werd dus niks.
Nu werkt het wel en kan ik voorlopig weer vooruit.
Ontzettend bedankt!

Kees
 
Status
Niet open voor verdere reacties.
Steun Ons

Nieuwste berichten

Terug
Bovenaan Onderaan