Hallo zusammen,
Hatte unter Excel 2010 ein einfaches Makro, welches eine bestehende Tabelle am Ende um eine Zeile erweitert und einen Hyperlink in der ersten Zelle einfügt. Unter Excel 365 wird die Tabelle nicht mehr um eine Zeile erweitert und der Hyperlink wird unterhalb der Tabelle eingefügt.
Jemand eine Idee, was ich anpassen muss im Makro?
With ThisWorkbook.Worksheets("Projects").ListObjects("Projects")
.Parent.Hyperlinks.Add _
Anchor:=.Range(1, 1).Offset(.ListRows.Count + 1, 0), Address:="", _
SubAddress:="'" & ID & "'!A1", _
TextToDisplay:=ID
End With
Besten Dank
Grüsse Pean
Zum besseren Verständnis, hier ganze Makro, welches unter Excel 2010 prima funktionierte, unter Excel 365 aber nicht mehr richtig.
Das Makro erstellt ein Tabellenblatt und fügt in einer Tabelle einen Hyperlink dazu ein. Rot markiert, der Teil, welcher nicht mehr korrekt funktioniert unter Excel 365.
Anstatt die Tabelle um eine Zeile zu erweitern, wird der Eintrag nur unter der Tabell eingefügt.
Sub new_Project()
Dim sheet As Worksheet
Dim ID As String
Static lngCalc As Long
With Application
lngCalc = .Calculation
.ScreenUpdating = False
.EnableEvents = False
.DisplayAlerts = False
.Calculation = -4135
.Cursor = xlWait
End With
ID = ThisWorkbook.Sheets("Projects").Cells(5, 2).Value
ThisWorkbook.Sheets("template").Copy after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = ID
With ThisWorkbook.Worksheets("Projects").ListObjects("Projects")
.Parent.Hyperlinks.Add _
Anchor:=.Range(1, 1).Offset(.ListRows.Count + 1, 0), Address:="", _
SubAddress:="'" & ID & "'!A1", _
TextToDisplay:=ID
End With
Exit Sub
Moin!
So ganz ohne Datei ist das Problem schwierig nachzuvollziehen.
Aber warum erweiterst Du das ListObject nicht "vorschriftsmäßig" und verlässt Dich statt dessen auf die automatische Erweiterung?
Natürlich ungetestet:
PHP-Code:
With ThisWorkbook.Worksheets("Projects").ListObjects("Projects").ListRows.Add
.Parent.Parent.Hyperlinks.Add _
Anchor:=.Cells(1), Address:="", _
SubAddress:="'" & ID & "'!A1", _
TextToDisplay:=ID
End With
Gruß Ralf
Verwende nur:
Code:
Sub new_Project()
With ThisWorkbook
.Sheets("template").Copy , .Sheets(.Sheets.Count)
.Sheets(.Sheets.Count).Name = .Sheets("Projects").Cells(5, 2).Value
With .Sheets("Projects")
.Hyperlinks.Add .Cells(Rows.Count, 1).End(xlUp).Offset(1), , .Sheets(.Sheets.Count).Cells(1).Address(, , , True), .Cells(5, 2).Value
.ListObjects(1).Resize .Cells(1).CurrentRegion
End With
End With
End Sub
Hallo RPP63,
Danke für deinen Input. Die Erweiterung der Tabelle würde so funktionieren, jedoch wird danach kein Hyperlink in der letzten Zelle eingetragen.
Grüsse Pean
Hallo SNB,
Danke auch dir für den Input.
Bekomme bei der Ausführung von
.Hyperlinks.Add .Cells(Rows.Count, 1).End(xlUp).Offset(1), , .Sheets(.Sheets.Count).Cells(1).Address(, , , True), .Cells(5, 2).Value
folgende Fehlermeldung
"Objekt unterstützt diese Eigenschaft oder Methode nicht"
Grüsse
Pean
Hallo Pean,
Code:
With ThisWorkbook.Worksheets("Kundenliste").ListObjects("Tabelle2")
.Resize Range(.Range.Address).Resize(.Range.Rows.Count + 1)
.Parent.Hyperlinks.Add _
Anchor:=.Range(1, 1).Offset(.ListRows.Count, 0), Address:="", _
SubAddress:="'" & Kundennummer & "'!A1", _
TextToDisplay:=Kundennummer
' VBA, XML, HTML => Forum-HTML, © 2018 by KHV (VBA) und Haklesoft (VB)
Gruß Uwe
Vielen Dank Kuwert für deine schnelle Reaktion....funktioniert wieder perfekt.
Danke Case für dein Feedback....konnte die Lösung von Kuwert verwenden.
Grüsse
Pean
