AW: Probleme, alte Datei zu rekonstruieren, Makro...
06.12.2017 08:55:47
fcs
Hallo Jenny,
ich hab versucht das Makro an deine Wunschliste anzupassen.
Unklar ist mir aber noch was mit dem Hyperlink in Spalte E passieren soll.
Momentan bleibt der Hyperlink erhalten, es wird aber statt des Schauspielernamens jetzt ein Teil der Hyperlinkadresse angezeigt.
Gruß
Franz
Sub Makro1()
' Tastenkombination: Strg+i
Dim i, zt1&, von&, bis As Long
Dim Grafiken As Shape
Dim c As Range, a As Variant
Dim wksListe As Worksheet, wks3 As Worksheet, wks5 As Worksheet
Application.ScreenUpdating = False
Set wksListe = Sheets("Tabelle1")
Set wks3 = Sheets("Tabelle3")
Set wks5 = Sheets("Tabelle5")
With wksListe
'letzte Zeile mit Daten in Spalte A
zt1 = .Cells(.Rows.Count, 1).End(xlUp).Row
von = 1
'Anzahl Zeilen mit Inhalt in "Tabelle5" Spalte B
With wks5
bis = .Cells(.Rows.Count, 2).End(xlUp).Row
End With
If bis > 1 Then
'ggf. letzte Zeile gemäß Anzahl "bis" kopieren
.Range(.Cells(zt1, 1), .Cells(zt1, 4)).EntireRow.Copy _
Destination:=.Range(.Cells(zt1 + 1, 1), .Cells(zt1 + bis - von, 1))
End If
With wks5
'Zellen mit Hyperlinks in Spalte B(2) kopieren nach Spalte E (5)
.Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 5)
'Namen in Spalte B(2) kopieren
.Range(.Cells(von, 2), .Cells(bis, 2)).Copy
End With
'in Spalte F(6) nur Werte einfügen
.Cells(zt1, 6).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
With wks3
'Geburtsdatum aus Spalte E(5) kopieren
.Range(.Cells(von, 5), .Cells(bis, 5)).Copy
End With
'in Spalte G(7) nur Werte einfügen
.Cells(zt1, 7).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
'in Spalte E einen Teil-Text des Hyperlinks anzeigen (Hyperlink bleibt erhalten)
For Each c In .Range(.Cells(zt1, 5), .Cells(zt1 + bis - von + 1, 5))
If c.Hyperlinks.Count > 0 Then
a = Split(c.Hyperlinks(1).Address, "/")
c.Offset(0, 0).Value = a(UBound(a) - 1)
End If
Next
'Daten sortieren
.Range(.Cells(1, 1), .Cells(zt1 + bis, 15)).Sort _
key1:=.Range("G1"), Order1:=xlDescending, _
key2:=.Range("D1"), Order2:=xlAscending, Header:=xlNo
End With
'Inhalte Tabelle3 und Tabelle5 löschen
With wks5
.Range(.Cells(1, 1), .Cells(bis, 3)).Clear
End With
With wks3
.Range(.Cells(1, 1), .Cells(bis, 4)).Clear
For Each Grafiken In .Shapes
Grafiken.Delete
Next
End With
End Sub