habe folgendes Makro gehabt
Sub Makro3()
' Makro3 Makro
' Tastenkombination: Strg+i
Dim zt1&, von&, bis As Long
Dim Grafiken As Shape
Dim c As Range, a As Variant
Application.ScreenUpdating = False
With Sheets("Tabelle1")
zt1 = .Cells(.Rows.Count, 1).End(xlUp).Row
von = 1
With Sheets("Tabelle2")
bis = .Cells(.Rows.Count, 2).End(xlUp).Row
'Inhalt Spalte B nach tabelle1 kopieren
.Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 7)
End With
With Sheets("Tabelle3")
'Inhalt aus Spalte E kopieren
.Range(.Cells(von, 5), .Cells(bis, 5)).Copy
End With
'In Spalte H einfügen
.Cells(zt1, 8).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If bis > 1 Then
'Spalte A bis C durch kopieren auffüllen
.Range(.Cells(zt1, 1), .Cells(zt1, 3)).Copy _
Destination:=.Range(.Cells(zt1 + 1, 1), .Cells(zt1 + bis - von, 1))
End If
Application.CutCopyMode = False
With Sheets("Tabelle1")
Range(.Cells(zt1 - 1, 4), .Cells(zt1 - 1, 5)).Copy _
Destination:=.Range(Cells(zt1, 4), Cells(zt1 + bis - von, 4))
Application.CutCopyMode = False
End With
' Stop
For Each c In Range(.Cells(zt1, 7), .Cells(zt1 + bis - von, 7))
If c.Hyperlinks.Count > 0 Then
a = Split(c.Hyperlinks(1).Address, "/")
' For i = 1 To UBound(a): MsgBox a(i): Next
c.Offset(0, -1).Value = a(UBound(a) - 1)
End If
Next
'Daten nach Spalte E aufsteigend, dann H absteigend sortieren
.Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 15)).Sort _
key1:=.Range("E1"), Order1:=xlAscending, _
key2:=.Range("H1"), Order2:=xlDescending, Header:=xlNo
End With
With Sheets("Tabelle2")
'Daten in Spalten A bis C löschen
.Range(.Cells(1, 1), .Cells(bis, 3)).Clear
End With
With Sheets("Tabelle3")
'Daten in Spalten A bis D löschen
.Range(.Cells(1, 1), .Cells(bis, 4)).Clear
For Each Grafiken In .Shapes
Grafiken.Delete
Next
End With
Application.ScreenUpdating = True
End Sub
welches funktioniert hat,habe jetzt in der Tabelle Spalte D gelöscht, somit ist jetzt Spalte E die Spalte D, die Spalte F ist jetzt Spalte E usw.
und habe dann versucht das Makro anzupassen und bin jetzt soweit:
Sub Makro3()
' Makro3 Makro
' Tastenkombination: Strg+i
Dim zt1&, von&, bis As Long
Dim Grafiken As Shape
Dim c As Range, a As Variant
Application.ScreenUpdating = False
With Sheets("Tabelle1")
zt1 = .Cells(.Rows.Count, 1).End(xlUp).Row
von = 1
With Sheets("Tabelle2")
bis = .Cells(.Rows.Count, 2).End(xlUp).Row
'Inhalt Spalte B nach tabelle1 kopieren
.Range(.Cells(von, 2), .Cells(bis, 2)).Copy Sheets("Tabelle1").Cells(zt1, 6)
End With
With Sheets("Tabelle3")
'Inhalt aus Spalte E kopieren
.Range(.Cells(von, 5), .Cells(bis, 7)).Copy
End With
'In Spalte H einfügen
.Cells(zt1, 7).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
If bis > 1 Then
'Spalte A bis C durch kopieren auffüllen
.Range(.Cells(zt1, 1), .Cells(zt1, 3)).Copy _
Destination:=.Range(.Cells(zt1 + 1, 1), .Cells(zt1 + bis - von, 1))
End If
Application.CutCopyMode = False
Sheets("Tabelle1").Range("D" & zt1 - 1).Copy _
Sheets("Tabelle1").Range("D" & zt1 + bis - von)
' Stop
For Each c In Range(.Cells(zt1, 6), .Cells(zt1 + bis - von + 1, 5))
If c.Hyperlinks.Count > 0 Then
a = Split(c.Hyperlinks(1).Address, "/")
' For i = 1 To UBound(a): MsgBox a(i): Next
c.Offset(0, -1).Value = a(UBound(a) - 1)
End If
Next
'Daten nach Spalte E aufsteigend, dann H absteigend sortieren
.Range(.Cells(1, 1), .Cells(zt1 + 1 + bis - von, 15)).Sort _
key1:=.Range("D1"), Order1:=xlAscending, _
key2:=.Range("G1"), Order2:=xlDescending, Header:=xlNo
End With
With Sheets("Tabelle2")
'Daten in Spalten A bis C löschen
.Range(.Cells(1, 1), .Cells(bis, 3)).Clear
End With
With Sheets("Tabelle3")
'Daten in Spalten A bis D löschen
.Range(.Cells(1, 1), .Cells(bis, 4)).Clear
For Each Grafiken In .Shapes
Grafiken.Delete
Next
End With
Application.ScreenUpdating = True
End Sub
es kommt zwar keine Fehlermeldung, aber etwas funktioniert nicht so wie es soll, z.B. wird der Text in Spalte D nicht kopiert.Könnt ihr mir helfen?
Viele Grüße und danke
Jenny