Range in ARRAY error 13, Typ unverträgli
17.06.2020 11:01:33
Günter
ich habe ein Problem beim "befüllen" eines Arrays auf einem Tabellenblatt.
Mit einer gewissen Anzahl von Felders funktioniert es. Wenn ich einen Bereich angebe ("A2:A10"), geht das Makro auf die Bretter mit Laufzeitfehler 13, Typen unverträglich.
Ich vermute eine fehlende oder falsche DIM-Anweisung.
Ich möchte ca. 100 Felder (A2 bis A101) in das Array schreiben.
Anbei das Coding, die relevanten Zeilen sind fett.
Sub neu()
Dim verz As String
Dim datei As String
Dim Zeile_L As Long
Dim Zeile_W As Long
'altdaten löschen
With Worksheets("Übersicht")
.Select
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
End If
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
'MsgBox Zeile_L
If Zeile_L >= 5 Then
.Range("a5:L" & Zeile_L).ClearContents
End If
End With
With Worksheets("PT")
.Select
If .AutoFilterMode = True Then
If .FilterMode = True Then .ShowAllData
End If
Zeile_W = .UsedRange.Row + .UsedRange.Rows.Count - 1
'MsgBox Zeile_W
If Zeile_W >= 5 Then
.Range("a5:W" & Zeile_W).ClearContents
End If
End With
verz = ActiveWorkbook.Path
'MsgBox verz
Dim strDateiname As String
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = False
.InitialFileName = verz & "\*.xlsx"
If .Show = -1 Then
strDateiname = .SelectedItems(1)
End If
End With
Workbooks.Open filename:=strDateiname
datei = ActiveWorkbook.Name
'MsgBox datei
Worksheets("Übersicht").Select
Range("A14:L" & Range("L" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Sheets(1).Range("A5").PasteSpecial Paste:=xlAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Worksheets("PT").Select
Range("A5:W" & Range("W" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Sheets(2).Range("A5").PasteSpecial Paste:=xlAll, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
' Zwischenablage löschen, da sonst Abfrage beim Schliessen der Quell-Datei
Application.CutCopyMode = False
' Schliessen der Quell-Datei
Workbooks(datei).Activate
ActiveWorkbook.Close savechanges = False
Worksheets("Übersicht").Select
' Relevante AKZ selektieren (aus Tabelle1) Bereich ohne Überschriften
' Call DeleteRows(Range("A6:L999"), 1, Array(Sheets("Tabelle1").Range("A2:A10").Value))
Call DeleteRows(Range("A6:L999"), 1, Array(Sheets("Tabelle1").Range("A2").Value, _
Sheets("Tabelle1").Range("A3").Value, _
Sheets("Tabelle1").Range("A4").Value, _
Sheets("Tabelle1").Range("A5").Value, _
Sheets("Tabelle1").Range("A6").Value, _
Sheets("Tabelle1").Range("A7").Value, _
Sheets("Tabelle1").Range("A8").Value, _
Sheets("Tabelle1").Range("A9").Value, _
Sheets("Tabelle1").Range("A10").Value, _
Sheets("Tabelle1").Range("A11").Value))
' Spaltenbreite setzen
Columns("A:A").ColumnWidth = 10
Columns("B:B").ColumnWidth = 30
Columns("C:C").ColumnWidth = 15
Columns("D:L").ColumnWidth = 20
Columns("H:H").ColumnWidth = 5
'Zeilenhöhe anpassen
Cells.Rows.AutoFit
Worksheets("PT").Select
' Relevante AKZ selektieren (3601, 3701, 3769)
' Call DeleteRows(Range("A6:L999"), 2, Array(Sheets("Tabelle1").Range("A2:A10").Value))
Call DeleteRows(Range("A6:L999"), 2, Array(Sheets("Tabelle1").Range("A2").Value, _
Sheets("Tabelle1").Range("A3").Value, _
Sheets("Tabelle1").Range("A4").Value, _
Sheets("Tabelle1").Range("A5").Value, _
Sheets("Tabelle1").Range("A6").Value, _
Sheets("Tabelle1").Range("A7").Value, _
Sheets("Tabelle1").Range("A8").Value, _
Sheets("Tabelle1").Range("A9").Value, _
Sheets("Tabelle1").Range("A10").Value, _
Sheets("Tabelle1").Range("A11").Value))
' Spaltenbreite setzen
Columns("A:B").ColumnWidth = 5
Columns("C:G").ColumnWidth = 30
Columns("H:I").ColumnWidth = 10
Columns("J:W").ColumnWidth = 25
'Zeilenhöhe anpassen
Cells.Rows.AutoFit
Worksheets("PT").Select
Range("A1").Select
Worksheets("Übersicht").Select
Range("A1").Select
End Sub
Sub DeleteRows(rngData As Range, lngCriteriaColumn As Long, arrCriteria)
Dim rngC As Range, rngDel As Range
For Each rngC In rngData.Columns(lngCriteriaColumn).Cells
If IsError(Application.Match(rngC, arrCriteria, 0)) Then
If rngDel Is Nothing Then
Set rngDel = rngC
Else
Set rngDel = Union(rngDel, rngC)
End If
End If
Next rngC
If Not rngDel Is Nothing Then
rngDel.EntireRow.Delete
End If
End Sub