Problem mit Code
25.04.2018 10:45:45
Philip
Ich habe einen Code der am anfang auch funktioniert hat aber jetzt leider nicht mehr.
Ich bekomme immer den fehler "Index ausserhalb des gültigen Bereichs".
Mit diesem Code suche ich etwas in der Tabelle und übertrage dieses in die Listbox und folge dort dem Hyperlink.
Hoffe ihr könnt mir helfen.
Private Sub CommandButton1_Click()
Dim wksQ As Worksheet
Dim strKundennummer As String
Dim lngSpalte As Long
Dim rngSuchBereich As Range, rngList As Range, rng As Range
Dim vntGesucht As Variant
Dim lngGefundenInZeile As Long
Dim straArray() As String
Dim rngGefunden As Range
Dim lngZeileArray As Long
Dim strFirstAddress As String
Set wksQ = ThisWorkbook.Worksheets("Probenahme")
strKundennummer = Trim(TextBox1.Text)
vntGesucht = Replace(strKundennummer, "*", "") & "*"
lngSpalte = 6
Set rngSuchBereich = wksQ.Columns(lngSpalte)
lngGefundenInZeile = 0
Set rngGefunden = rngSuchBereich.Find(What:=vntGesucht, After:=rngSuchBereich.Cells(1), _
LookIn:=xlValues, LookAt:=xlWhole)
If Not rngGefunden Is Nothing Then
strFirstAddress = rngGefunden.Address
Do
If rngList Is Nothing Then
Set rngList = rngGefunden
Else
Set rngList = Union(rngList, rngGefunden)
End If
Set rngGefunden = rngSuchBereich.FindNext(rngGefunden)
Loop While Not rngGefunden Is Nothing And rngGefunden.Address strFirstAddress
End If
Dim hyp As String
Dim pfad As String
pfad = "Z:\pfad\"
If Not rngList Is Nothing Then
ReDim straArray(1 To rngList.Rows.Count, 1 To 9) As String
For Each rng In rngList
lngZeileArray = lngZeileArray + 1
straArray(lngZeileArray, 1) = wksQ.Cells(rng.Row, 1)
straArray(lngZeileArray, 2) = wksQ.Cells(rng.Row, 2)
straArray(lngZeileArray, 3) = wksQ.Cells(rng.Row, 4)
straArray(lngZeileArray, 4) = wksQ.Cells(rng.Row, 5)
straArray(lngZeileArray, 5) = wksQ.Cells(rng.Row, 6)
straArray(lngZeileArray, 6) = wksQ.Cells(rng.Row, 7)
straArray(lngZeileArray, 7) = wksQ.Cells(rng.Row, 8)
straArray(lngZeileArray, 8) = wksQ.Cells(rng.Row, 13)
hyp = wksQ.Cells(rng.Row, 13)
ActiveSheet.Hyperlinks.Add Anchor:=wksQ.Cells(rng.Row, 18), _
Address:=Dir(pfad & hyp & "*" & ".pdf"), _
TextToDisplay:=pfad & Dir(pfad & hyp & "*" & ".pdf")
straArray(lngZeileArray, 9) = wksQ.Cells(rng.Row, 18)
Next
ListBox1.Clear
ListBox1.ColumnCount = 9
ListBox1.ColumnHeads = False
ListBox1.List = straArray
ListBox1.ColumnWidths = "2cm;3cm;8cm;5cm;4cm;3cm;2cm;3cm;0cm"
ListBox1.Font.Size = 12
Label1 = "Anzahl:" & ListBox1.ListCount
Else
ListBox1.Clear
MsgBox "Artikel-Nr. nicht gefunden!"
End If
End Sub
Der Fehler tritt immer bei der Zeile
straArray(lngZeileArray, 1) = wksQ.Cells(rng.Row, 1)
Gruss