Makro als Addin nicht lauffähig (Laufzeitfehler)
David
ich habe mir ein kleines Makro zusammengesucht, welches mir 3 Spalten ( H I J ) an den Kopf der Mappe stellt ( A B C ), die Mappe wird dann durchsucht und aus den Wörtern der Spalte H wird dann eine neue Tabelle erstellt.
In der Arbeitsmappe befindet sich folgender Code zur Erstellung eines Addin (die Funktio isAddin habe ich auf true gesetzt):
Private Sub Workbook_Open()
'Menü erzeugen
Dim Menue As CommandBarPopup
Dim Schaltflaeche As CommandBarButton
' Menüpunkt anlegen
With Application.CommandBars("Worksheet Menu Bar")
Set Menue = .Controls.Add(Type:=msoControlPopup, _
before:=.Controls.Count, temporary:=True)
End With
' Unterpunkte im Menü anlegen
Menue.Caption = "&Tool-Box" ' Name des Menüs
Set Schaltflaeche = Menue.Controls.Add
With Schaltflaeche
.Style = msoButtonIconAndCaption ' Format für Menüpunkt: Icon und Text
.FaceId = 1445 ' Nummer des Icons
.Caption = "Splitten" ' Name der Menüzeile
.OnAction = "Splitter" ' Aktion ausführen //// Mein Makro heißt Splitter
.BeginGroup = True ' Trennlinie erzeugen
End With
End Sub
Sub Splitter()
'Precheck
Dim cell As Range
Dim lngLast As Long
lngLast = Cells(Rows.Count, 1).End(xlUp).Row
For Each cell In Range("H1:H" & lngLast)
If cell.Value = "" Then
cell.Value = "#ERROR"
End If
Next
'Precheck
Dim i As Long
Dim n As Long
Dim k As Integer
Dim d As Integer
Dim ar As Variant
Dim arErg As Variant
Dim arSep As Variant
Dim Dic As Object
Dim ws As Worksheet
Dim iKS As Integer 'Kriterium-Spalte
iKS = 8
Set Dic = CreateObject("scripting.dictionary")
For i = 2 To UBound(ar)
If Len(ar(i, iKS)) Then _
Dic(ar(i, iKS)) = Dic(ar(i, iKS)) + 1
Next
arSep = Sort(Dic.keys)
For d = 0 To UBound(arSep)
ReDim arErg(1 To Dic(arSep(d)) + 1, 1 To UBound(ar, 2))
For i = 1 To UBound(ar)
If ar(i, iKS) = arSep(d) Or i = 1 Then
n = n + 1
For k = 1 To UBound(ar, 2)
arErg(n, k) = ar(i, k)
Next
End If
Next
n = 0
If IsSheetExist(arSep(d)) Then
Set ws = Worksheets(CStr(arSep(d)))
ws.Select
ws.UsedRange.Clear
Else
Set ws = Worksheets.Add(After:=Sheets(Sheets.Count))
ws.Name = arSep(d)
End If
ws.Range("A1").Resize(UBound(arErg), UBound(arErg, 2)) = arErg
ws.Range("H:J").Cut
ws.Range("A:A").Insert xlToRight
Next
End Sub
Function Sort(ar)
Dim i As Long, k As Long, h
For i = UBound(ar) To 0 Step -1
For k = 0 To i - 1
If ar(k) > ar(k + 1) Then
h = ar(k)
ar(k) = ar(k + 1)
ar(k + 1) = h
End If
Next
Next
Sort = ar
End Function
Function IsSheetExist(ByVal wsName As String) As Boolean
On Error Resume Next
IsSheetExist = Not Worksheets(wsName) Is Nothing
End Function In der ersten Mappe funktioniert es, jedoch wenn ich weitere Mappen mit dem Addin bearbeiten will sagt er mir nur:
Laufzeitfehler 13 typen unverträglich
Ich hoffe Jemand kann mir dabei behilflich sein.
Gruß
David
Anzeige