Liebe Excel-Anwender,
ich bin absolut kein Vba Mensch und wende mich deshalb an euch.
Momentan hab ich ein Projekt mit einem Planungstool das mit Excel arbeitet.
In diesem Tool wird mit Buttons gearbeitet, diese Buttons sind in einer Tabelle hinterlegt. Diese Buttons sind in einem Modul angelegt. Ich werde den Code beifügen.
Momentan wird für jede Planung eine extra Excel Arbeitsmappe angelegt, es soll aber möglich sein mehrere Planungen innerhalb einer Excel anzulegen.
Da das einfache Kopieren der Tabelle mit den Buttons nicht funktioniert, dachte ich mir, man kann den Code in VBA ja in das Tabellenblatt reinkopieren und das Modul dann entfernen. Nach erneutem Kopieren der Exceltabelle in der die Buttons sind und versuchen eine Planung anzulegen kommt der Fehler 400.
Kann mir hier jemand unter die Arme greifen?
Nochmals zusammengefasst: Das Ziel ist es die Tabelle mit den Funktionen und Buttons kopieren zu können und so mehrere Male innerhalb einer Excel Arbeitsmappe anlegen zu können.
Ich bedanke mich schonmal vielmals im Voraus für die Hilfe
Grüße Elia
Hier ist Code von dem ich gesprochen hab
Function GetPattern(Count)
'array of available patterns in Excel 2016
PatternSelection = Array(xlPatternChecker, xlPatternCrissCross, xlPatternDown, xlPatternGray16, _
xlPatternGray25, xlPatternGray50, xlPatternGray75, xlPatternGray8, _
xlPatternGrid, xlPatternHorizontal, xlPatternLightDown, xlPatternLightHorizontal, _
xlPatternLightUp, xlPatternLightVertical, xlPatternSemiGray75, xlPatternUp, xlPatternVertical)
'return the pattern value based on parameter count
GetPattern = PatternSelection(Count)
End Function
Sub ClearAutofilter()
'reset autofilter to show all lines
On Error GoTo Ignore:
ActiveSheet.ShowAllData
Ignore:
End Sub
Sub ButtonResetClick()
Application.ScreenUpdating = False
'Reset all filter values to default
Range("A79") = "*"
Range("B79") = "-"
Range("C79") = "*"
Range("E79") = "*"
Range("G79") = "*"
'filter with reseted filter
Call ButtonUpdateChartClick
End Sub
Sub ButtonUpdateChartClick()
Application.ScreenUpdating = False
'first reset autofiter again to show everything
Call ClearAutofilter
'update chart view and define which line to are to be shown
Call SetLineStatus
'filter for the value 1 which means this line is to be shown
ActiveSheet.Range("$A$97:$X$749").AutoFilter Field:=23, Criteria1:="1"
Application.ScreenUpdating = True
End Sub
Sub SetLineStatus()
Dim CurrentLine As Integer
Dim LineName, LineStatus, PlantName, LastPlant As String
Dim BorderColor, FillColor As Long
Dim BorderSize, PatternCount As Integer
Dim BorderStyle As Long
Dim Ok As Integer
Dim CapaChart As Chart
Dim CapaLinie As Object
'ActiveSheet.Unprotect "GSMFCisthebest"
Application.ScreenUpdating = False
'all production lines are processes one by one starting with the first line
CurrentLine = StartingLine
'remember which was the last plant processed, if plant changes, pattern needs to be reset as well
LastPlant = ""
'as pattern is selected in the same order, remember which was the last pattern used
PatternCount = 0
'loop through all lines until the end is hit, which is the cell containing the value ***
While (Range("A" & CurrentLine).Value > "***")
'retrieve the data for the current line being processed and assign them to the variables
LineName = Range("A" & CurrentLine).Value
LineStatus = Range("V" & CurrentLine).Value
PlantName = Range("B" & CurrentLine).Value
'only do something if this line is filled
If LineName > "" Then
'select the style of border based on line status
Select Case LineStatus
Case "Ordered"
BorderColor = RGB(0, 0, 0) 'black dotted
BorderSize = 2
BorderStyle = msoLineDash
Case "Planned"
BorderColor = RGB(255, 0, 0) 'red dotted
BorderSize = 2
BorderStyle = msoLineDash
Case "This MAR"
BorderColor = RGB(255, 0, 0) 'red bold
BorderSize = 2
BorderStyle = msoLineSolid
Case "In Production"
BorderColor = RGB(0, 0, 0) 'black bold
BorderSize = 2
BorderStyle = msoLineSolid
Case Else
BorderColor = RGB(0, 0, 0) 'black fine
BorderSize = 0.25
BorderStyle = msoLineSolid
End Select
'If plant has changed, save as LastPlant and change the color in the chart
If PlantName > LastPlant Then
'MsgBox PlantName
LastPlant = PlantName
PlantRow = ActiveWorkbook.Worksheets("Plant Data").Range("A:A").Find(PlantName).Row
FillColor = ActiveWorkbook.Worksheets("Plant Data").Range("C" & PlantRow).Interior.Color
'MsgBox FillColor
End If
'MsgBox LineName
'Set the chart according to the defined border and pattern style above
Set CapaChart = ThisWorkbook.ActiveSheet.ChartObjects(1).Chart
Set CapaLinie = CapaChart.FullSeriesCollection(LineName)
With CapaLinie.Format.Line
.Visible = msoTrue
.ForeColor.RGB = BorderColor
.Transparency = 0
.Weight = BorderSize
.DashStyle = BorderStyle
End With
'Pattern
CapaLinie.Format.Fill.ForeColor.RGB = RGB(255, 255, 255)
CapaLinie.Interior.Pattern = GetPattern(PatternCount)
CapaLinie.Interior.PatternColor = FillColor
'Solid
'CapaLinie.Interior.Pattern = xlSolid
'CapaLinie.Format.Fill.ForeColor.RGB = FillColor
'go to next pattern
PatternCount = PatternCount + 1
'maximum count of pattern is reached, reset to 0
If PatternCount >= 15 Then PatternCount = 0
End If
'Process next line
CurrentLine = CurrentLine + 1
Wend
'ActiveSheet.Protect "GSMFCisthebest", False, True
Application.ScreenUpdating = True
End Sub
Sub FilterLines()
'
' FilterLines Makro
'
Dim LineFilterCriteria As String
Dim LineWish As Integer
Application.ScreenUpdating = False
Call ClearAutofilter
LineWish = ActiveSheet.Range("N79")
If LineWish > 70 Then
LineWish = 70
ActiveSheet.Range("N79") = "70"
End If
LineFilterCriteria = "=" & LineWish
ActiveSheet.Range("$A$97:$X$744").AutoFilter Field:=24, Criteria1:=LineFilterCriteria _
, Operator:=xlAnd
Application.ScreenUpdating = True
End Sub