AW: Index ausserhalb des gültigen Bereichs
26.08.2022 15:40:13
Kina
Hallo Gerd,
Die Files sind alle 1:1 die selben, nur der Speicherort hat sich geändert und die Files sind über neue Hyperlinks verknüpft.
Hier einer der Codes:
Private Sub cmdEnter_Click()
'Fügt die eingetragenen Werte ins Tabellenblatt und schliesst das Formular frmContacts
Dim find As Boolean
Dim rng As Range
Dim wkbKontakt As Workbook, wksKontakt As Worksheet
On Error GoTo Fehler
'Spalte A nach wert durchsuchen
Set rng = Sheets("Metafile").Range("A:A").find(What:=cbbClient.Text, LookAt:=xlWhole, _
LookIn:=xlValues)
'Wenn wert entdeckt
If rng Is Nothing Then
find = False
MsgBox "Contact """ & cbbClient.Text & """ not found", vbInformation, _
"Search Contact in Metafile row A"
Else
find = True
If rng.Hyperlinks.Count > 0 Then
Application.EnableEvents = False
rng.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Set wkbKontakt = ActiveWorkbook
Set wksKontakt = wkbKontakt.Sheets("Contacts")
wksKontakt.Rows("9:9").Insert Shift:=xlDown
With Me.txtDate
If .Value "" Then wksKontakt.Range("B9").Value = Me.txtDate.Value
End With
With Me.cbbIniciator
If .ListIndex -1 Then wksKontakt.Range("C9").Value = Me.cbbIniciator.Value
End With
With Me.cbbChannel
If .ListIndex -1 Then wksKontakt.Range("D9").Value = Me.cbbChannel.Value
End With
With Me.txtSubject
If .Value "" Then wksKontakt.Range("E9").Value = Me.txtSubject.Value
End With
wkbKontakt.Save
Application.EnableEvents = True
Else
MsgBox "Zum Klienten """ & txtClient.Text & """ gibt es keinen Hyperlink", _
vbInformation, "Prüfen ob Klient ein Hyperlink zugeordnet ist"
End If
End If
Fehler:
With Err
Select Case .Number
Case 0 'Alles OK
Case -2147221014
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description & vbLf & vbLf _
& "Datei """ & rng.Hyperlinks(1).Address & """ zum Hyperlink existiert nicht"
Case Else
MsgBox "Fehler-Nr.: " & .Number & vbLf & .Description
End Select
End With
Application.EnableEvents = True
Unload frmNewContact
End Sub