Excel Zelleninhalte automatisch editieren/löschen

Dieses Thema Excel Zelleninhalte automatisch editieren/löschen im Forum "Microsoft Office Suite" wurde erstellt von PCDCharly, 18. Mai 2004.

Thema: Excel Zelleninhalte automatisch editieren/löschen Hi Excel-Profis. :D In Fortsetzung dieser Herausforderung hier gleich mal die nächste. ;D Also, ich habe nun...

  1. Hi Excel-Profis. :D

    In Fortsetzung dieser Herausforderung hier gleich mal die nächste. ;D

    Also, ich habe nun feine Excel-Dateien vorliegen mit allen möglichen Bildinfos. Eigentlich sogar mit zu vielen Infos, zumindest in einer Spalte (hier E). ;) Die sieht in etwa so aus:

    [​IMG]

    Wer hilft mir auf die Sprünge, ob und wie ich zumindest den oberen Bereich bis einschließlich Written by Adobe ... automatisch in allen Zellen entfernt kriege? Optional könnten auch die Zeile mit der Telefonnummer und die mit dem Copyright-Verweis weg, da die Listen eh nur für internen Gebrauch sind.

    Falls es von irgendeiner Bedeutung sein sollte: Die Beschreibung mit Caption gibt es in 95 Prozent der Fälle, aber nicht überall, die Bildgrößen sind in 95 Prozent der Fälle gleich, aber auch nicht überall. 8)

    Und nu? ;D

    eine gespannte Charly ;)
     
  2. Hach, es geht doch nix über Experten, die noch dazu so lieb sind, der Charly ein Makro zu basteln. Dem Projekt Fotoarchiv steht dank Matjes' Hilfe nix mehr im Wege. :D :D

    Und was für->ne Menge Nerven mir das rettet. ;)

    Thx Matjes! :-*
     
  3. Die Lösung erfolgte per Makro:

    Der Makro untersucht nacheinander die Zellen in Spalte E des aktiven Blattes.

    In der Initialisierung werden zunächst zwei Felder mit Suchbegriffen aufgebaut.

    f1 nimmt alle Suchbegriffe für->Zeile beginnt mit ...' auf.
    Beginnt eine Textzeile damit, soll Sie gelöscht werden.
    Ausführende Funktion dafür ist:
    Sub Flt_LoescheTextzeileWennSieMitSuchbegriffBeginnt

    f2 nimmt alle Suchbegriffe für->Zeile enthält ...' auf.
    Enthält eine Textzeile den Suchbegriff, soll Sie gelöscht werden.
    Ausführende Funktion dafür ist:
    Sub Flt_LoescheTextzeileWennSieSuchbegriffEnthaelt


    Im ersten Versuch war f2 nicht enthalten.
    In der Fotoarchivdatei waren jedoch sehr viel verschiedene Zeilen bzgl. Bildformat enthalten. Dies hätte bedeutet, alle möglichen Bildformate in f1() aufzunehmen. Die Lösung dafür war, jede Zeile mit dem prägnanten Teilstring 16.7 million colors (24 bit) zu löschen (f2()).

    Gruß Matjes :)

    Code:
    Option Explicit
    Option Base 1
    
    Public Sub Charlys_AufrauemenInSpalteE_2()
    
      Const c_sp = 5-> entspricht Spalte E
      
      Dim f1() As String->Feld für Suchbegriffe für->Zeile beginnt mit'
      Dim f2() As String->Feld für Suchbegriffe für->Zeile enthält'
      Dim s_orgtext As String, ws As Worksheet, l_rows As Long, n As Long
      
      Call Charlys_Aufraeumen_Init(f1(), f2())
      
      Set ws = ActiveSheet
      l_rows = ws.Cells(ws.Rows.Count, c_sp).End(xlUp).Row
      
      For n = 1 To l_rows
        s_orgtext = ws.Cells(n, c_sp).Value
        Call Flt_LoescheTextzeileWennSieMitSuchbegriffBeginnt(s_orgtext, f1())
        Call Flt_LoescheTextzeileWennSieSuchbegriffEnthaelt(s_orgtext, f2())
        ws.Cells(n, c_sp).Value = s_orgtext
      Next
      
      ws.Rows(1 & : & l_rows).AutoFit
      ws.Cells(1, c_sp).Select
      
      Set ws = Nothing
    End Sub
    
    Private Sub Charlys_Aufraeumen_Init(f1() As String, f2() As String)
     ->Suchstrings in Feld eintragen
      Dim n As Long
      n = 0: ReDim f1(1 To 1)
      
     ->Suchbegriffe für->Zeile beginnt mit ...' eintragen
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = 942 x 1772, 16.7 million colors (24 bit)
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = 1162 x 1772, 16.7 million colors (24 bit)
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = 1411 x 1772, 16.7 million colors (24 bit)
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = 1772 x 1162, 16.7 million colors (24 bit)
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = 1772 x 1249, 16.7 million colors (24 bit)
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = 2000 x 1312, 16.7 million colors (24 bit)
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = 180 x 180 DPI
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = 300 x 300 DPI
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = File written by Adobe Photoshop¨ 5.2
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = ---
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = Byline: 
      n = n + 1: ReDim Preserve f1(1 To n)
        f1(n) = Object Name: 
        
     ->Suchbegriffe für->Zeile enthaelt ...' eintragen
      n = 0: ReDim f2(1 To 1)
      n = n + 1: ReDim Preserve f2(1 To n)
        f2(n) = 16.7 million colors (24 bit)
    
    End Sub
    
    Sub Flt_LoescheTextzeileWennSieMitSuchbegriffBeginnt(ByRef s_orgtext As String, f1() As String)
    Dim pos1 As Long, pos2 As Long, n As Long
    Dim s_suchtext As String, s_tmp As String
    
    'Alle Stringzeilen im String, die mit einem Suchbegriff beginnen, loeschen
      For n = LBound(f1()) To UBound(f1())
        s_suchtext = f1(n)->nächster Suchbegriff
        pos1 = 1
        Do
          pos1 = InStr(pos1, s_orgtext, s_suchtext)
          If ((pos1 = 0) Or (pos1 = Null)) Then
            Exit Do->nicht gefunden
          Else
            If pos1 = 1 Then->erste Zeile Anfang ?
             ->erste vblf nach pos1 suchen
              pos2 = InStr(pos1 + Len(s_suchtext), s_orgtext, vbLf)
              If (pos2 = 0) Or (pos2 = Null) Then
               ->nur eine Zeile
                s_orgtext = : Exit Do
              Else
               ->mehr als eine Zeile
                s_orgtext = Right(s_orgtext, Len(s_orgtext) - pos2)
                pos1 = 1->wieder bei pos=1 beginnen
              End If
            Else->nicht Anfang 1.Zeile
              If (vbLf = Mid(s_orgtext, pos1 - 1, 1)) Then->Zeilenanfang ?
               ->erste vblf nach pos1 suchen
                pos2 = InStr(pos1 + Len(s_suchtext), s_orgtext, vbLf)
                If (pos2 = 0) Or (pos2 = Null) Then
                 ->letzte Zeile
                  s_orgtext = Left(s_orgtext, pos1 - 1): Exit Do
                Else
                 ->nicht letzte Zeile
                  s_orgtext = Left(s_orgtext, pos1 - 1) & _
                              Right(s_orgtext, Len(s_orgtext) - pos2)
                  pos1 = pos1-> nach pos2 weitersuchen
                End If
              Else
               ->kein Zeilenanfang -> weitersuchen
                pos1 = pos1 + Len(s_suchtext)
              End If
            End If
          End If
        Loop While (pos1 <> 0)
      Next
    End Sub
    
    Sub Flt_LoescheTextzeileWennSieSuchbegriffEnthaelt(ByRef s_orgtext As String, f2() As String)
      Dim pos1 As Long, pos2 As Long, pos3 As Long, pos4 As Long, n As Long
      Dim s_suchtext As String, s_tmp As String
      
    'Alle Stringzeilen im String, die den Suchbegriff enthalten, loeschen
      For n = LBound(f2()) To UBound(f2())
        s_suchtext = f2(n)->nächster Suchbegriff
        pos1 = 1
        Do
          pos1 = InStr(pos1, s_orgtext, s_suchtext)
          If ((pos1 = 0) Or (pos1 = Null)) Then
            Exit Do->nicht gefunden
          Else
           ->letzten Zeilenumbruch vor dem String
            If pos1 = 1 Then
              pos3 = 0
            Else
              s_tmp = Left(s_orgtext, pos1 - 1)
              pos4 = 1: pos3 = 0
              Do
                pos4 = InStr(pos4, s_tmp, vbLf)
                If ((pos4 = 0) Or (pos1 = Null)) Then
                Else
                  pos3 = pos4: pos4 = pos4 + 1
                End If
              Loop While pos4 <> 0
            End If
           ->erste vblf nach pos1 suchen
            pos2 = InStr(pos1 + Len(s_suchtext), s_orgtext, vbLf)
            
            If (pos3 = 0) And (pos2 = 0) Then->erste Zeile
             ->nur eine Zeile
              s_orgtext = : Exit Do
            ElseIf pos3 = 0 Then
             ->erste Zeile
              s_orgtext = Right(s_orgtext, Len(s_orgtext) - pos2)
              pos1 = 1->wieder bei pos=1 beginnen
            ElseIf pos2 = 0 Then
             ->letzte Zeile
              s_orgtext = Left(s_orgtext, pos3)
              Exit Do
            Else
             ->mittlere Zeile
              s_orgtext = Left(s_orgtext, pos3) & _
                              Right(s_orgtext, Len(s_orgtext) - pos2)
                  pos1 = pos2 + 1-> nach pos2 weitersuchen
            End If
          End If
        Loop While (pos1 <> 0)
      Next
    End Sub
     
  4. Respekt, Matjes! Dass das nicht mit Bordmitteln zu machen und ein Makro erforderlich ist, mit der von Dir beschriebenen Vorgehensweise, war mir schon klar. Jedoch bin ich immer wieder von den Programmiertalenten beeindruckt. Ich könnte das sicherlich auch, aber ich habe einfach keine Zeit mehr, so tief einzusteigen ;)

    Greetz, Trispac
     
  5. Na ich erst, zumal ich ohne diese Talente an meinen 27.000 zu bearbeitenden Zellen->ne Weile gesessen hätte. ;) 8)
     
  6. Ola,

    denk dran, bei 65535 ist schluß ... vielleicht solltest du mal langfristig über Access nachdenken
     
Die Seite wird geladen...

Excel Zelleninhalte automatisch editieren/löschen - Ähnliche Themen

Forum Datum
Excel-Feature gesucht Microsoft Office Suite 11. Okt. 2016
Excel Tabelle Werte zu ordnen Microsoft Office Suite 23. Sep. 2016
Excel: Bereiche auf 'leer' Überprüfen Microsoft Office Suite 15. Sep. 2016
Import Datensatz inkl = und - Zeichen in Excel/Libre CALC Software: Empfehlungen, Gesuche & Problemlösungen 20. Mai 2016
Bestimmter User kann seine Excel Dateien nicht mehr direkt öffnen Software: Empfehlungen, Gesuche & Problemlösungen 16. Apr. 2016