A lot of this code looks familiar. It looks like you used one of my old programs as a template 
.
You are doing things the hard way by replicating your code for each person. You can pass parameters to subroutines. I don’t know if this will solve your problem but it will make coding and debugging it easier.
I suggest that you modify the change event on Controlpannel to read:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B9")) Is Nothing Then
Select Case Range("B9")
Case "Chris": Bijwerken "CC"
Case "Els": Bijwerken "EV"
Case "René": Bijwerken "RH"
Case "Yves": Bijwerken "YG"
End Select
End If
End Sub
Then make a “Generic” Biweken subroutine
Sub Bijwerken(Initials As String)
DataKopieren Initials
KopieerWaarden_Grafiek Initials
End Sub
And likewise a generic DatKopieren
Sub DataKopieren(Initials as String)
Dim MyPath As String
Dim MyFile As String
Dim xlThis As Workbook
Dim xlData As Workbook
Dim shThis As Worksheet
Dim shData As Worksheet
Dim LRow As Long, LCol As Long
Set xlThis = ThisWorkbook
Set shThis = xlThis.Sheets("Data")
MyPath = Range("Def_Dir")
MyFile = Range("Data_File")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' Clear the old data
ClearTable "Data", "Table_Data"
' Open data workbook
Set xlData = Workbooks.Open(MyPath & "\" & MyFile)
' Set the sheet and get the last row and column
Set shData = xlData.Sheets(1)
LRow = shData.Range("A" & Rows.Count).End(xlUp).row
LCol = shData.Cells("1", Columns.Count).End(xlToLeft).Column
' Set the filter
shData.Range(shData.Cells(1, 1), shData.Cells(LRow, LCol)).AutoFilter Field:=3, Criteria1:= Initials
shData.Range(shData.Cells(1, 1), shData.Cells(LRow, LCol)).SpecialCells(xlCellTypeVisible).Copy
shThis.Range("A1").PasteSpecial xlPasteValues
' Close the workbook
Workbooks(MyFile).Close savechanges:=False
Sheets("Controlepaneel").Select
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("A1").Select
SubtotaalMaken
End Sub
Next a generic KopieerWaarden_Grafiek
Sub KopieerWaarden_Grafiek(Initials As String)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Worksheets("Grafiek").Activate
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
ThisWorkbook.Worksheets("Subtotaal").Cells.Copy
ThisWorkbook.Worksheets("Grafiek").Select
Selection.PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=True, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats
ActiveSheet.Outline.ShowLevels rowlevels:=1
Laatste3KolommenVerwijderen
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("A1").Select
GrafiekMaken Initials
MsgBox "Klaar!" & vbCr & vbCr & "De gegevens werden verwerkt.", vbInformation, "Verkoopsresultaten"
End Sub
And finally a generic GrafiekMaken – note that I deleted the title. I’ll address that later. In this case, you don’t need to pass the parameter since the only thing you need it for is to set the title and we will do that elsewhere.
Sub GrafiekMaken()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Range("A1")
.Parent.ListObjects.Add(xlSrcRange, Range(.End(xlDown), .End(xlToRight)), , xlYes).Name = "Tabel1"
End With
Range("a1").Select
Selection.CurrentRegion.Select
MyRange = Selection.Address
mysheetname = ActiveSheet.Name
ActiveSheet.ChartObjects.Add(100, 60, 500, 250).Select
Application.CutCopyMode = False
ActiveChart.ChartWizard _
Source:=Sheets(mysheetname).Range(MyRange), _
Gallery:=xlColumnClustered, Format:=10, PlotBy:=xlRows, _
CategoryLabels:=1, SeriesLabels:=1, HasLegend:=0, _
CategoryTitle:="", _
ValueTitle:="", ExtraTitle:=""
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Range("a1").Select
End Sub
To set the title, go to the Controlepanneel and set a cell (for example B11) ="Omzet 2016 - " & B9. Then go to the chart and click in the title. Then go to the formula bar, type = and then select this cell.
There is probably a better way of doing this using a “template” chart and named dynamic ranges rather than building the chart with VBA.
If you decide to try that, here are a couple of articles that will help.
http://www.utteraccess.com/wiki/inde...Dynamic_Ranges
http://www.utteraccess.com/wiki/inde...namic_Charting
LinkBack URL
About LinkBacks
Register To Reply
. I first posted this thread in the vba/macro section, but since I have this problem with one of my charts, I moved it to this section.
Bookmarks