Microsoft Excel

Herbers Excel/VBA-Archiv

Probleme, alte Datei zu rekonstruieren, Makro...


Betrifft: Probleme, alte Datei zu rekonstruieren, Makro... von: Jenny
Geschrieben am: 03.12.2017 20:31:52

Hallo an euch alle,

ich habe eine verlorengegangene Datei rekonstruiert, nur das alte Makro scheint nicht mehr zu funktionieren, weil der Aufbau der Tabelle wohl dann jetzt doch ein anderer ist als damals.

Ich habe hier eine Beispieltabelle mit einer Legende was das Makro hat machen sollen.

https://www.herber.de/bbs/user/118076.xlsm

Das Makro ist in der Tabelle gespeichert.

Bitte helft mir das Ganze so abzuändern, dass das Makro wieder funktioniert.

Danke
Jenny

  

Betrifft: AW: Probleme, alte Datei zu rekonstruieren, Makro... von: fcs
Geschrieben am: 06.12.2017 08:55:47

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



  

Betrifft: AW: Probleme, alte Datei zu rekonstruieren, Makro... von: Jenny
Geschrieben am: 06.12.2017 18:00:06

Hallo Frank,

danke schonmal für deine viele Mühe. Werde jedoch aller vorraussicht nach erst morgen zum testen kommen.
Ich muss jedoch gestehen, mir ist ein Schönheitsfehler bei der Beschreibung unterlaufen. Ich hab ja gesagt, dass die Inhalte der Tabellen3 und 5 gelöscht werden sollen. Tabelle3 Spalte E darf nicht mitgelöscht werden. Sonst muss ich die Formel ja jedesmal wieder einfügen. Stattdessen schwebt mir vor, die Formel in ich sag mal 500 Zeilen zu kopieren um für alle Datenmengen gewappnet zu sein. zu deiner Frage mit den Hyperlinks in Spalte E. Können gelöscht werden. Einfacher Grund, ich gehe davon aus, dass das wenn es fertig ist mehr als 100000 Datensätze werden. Das würde ja sowieso die Anzahl der Hyperlinks die in einer Excel Mappe möglich sind übersteigen oder?

Gruß
Jenny


  

Betrifft: AW: Probleme, alte Datei zu rekonstruieren, Makro... von: fcs
Geschrieben am: 07.12.2017 06:01:23

Hallo Jenny,


hier das Makro angepasst bezuglich der Inhalte in Spalte E.
Das löschen der Werte in den Tabellenblättern passte schon. Hier hatte ich dein ursprüngliches Makro nicht geändert.

LG
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
           'in Spalte E der Lste einen Teil-Text des Hyperlinks in Spale B anzeigen
            For Each c In .Range(.Cells(von, 2), .Cells(bis, 2)).Cells
                If c.Hyperlinks.Count > 0 Then
                    a = Split(c.Hyperlinks(1).Address, "/")
                    wksListe.Cells(zt1, 5).Offset(c.Row - 1, 0).Value = a(UBound(a) - 1)
                End If
            Next
            '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
             
        
        '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



  

Betrifft: AW: Probleme, alte Datei zu rekonstruieren, Makro... von: Jenny
Geschrieben am: 07.12.2017 14:42:06

Hallo Franz,

das sieht doch echt toll aus. Danke
Darf ich noch eine kleine Bitte äußern? Lässt sich die Schriftart in Spalte B an die anderen Spalten anpassen? also fett weg und Schriftgröße 11? Kann das Makro das auch noch übernehmen?
Die Texte werden halt in fett und 24 aus dem Internet kopiert.

Gruß und danke für die viele Mühe
Jenny


  

Betrifft: AW: Probleme, alte Datei zu rekonstruieren, Makro... von: fcs
Geschrieben am: 08.12.2017 02:49:47

Hallo Jenny,

füge die folgenden Zeilen vor dem Sortiern ein.

             
        'Spalte B formatieren
        With .Range("B:B")
            With .Font
                .Size = 11
                .Bold = False
            End With
        End With
        'Daten sortieren

LG
Franz


  

Betrifft: AW: Probleme, alte Datei zu rekonstruieren, Makro... von: Jenny
Geschrieben am: 09.12.2017 14:23:40

Hallo Franz,

das hat auch geklappt, vielen Dank für deine Mühe
Jenny