Excel Zelleninhalte automatisch editieren/löschen

PCDCharly · 18.05.2004

Hi Excel-Profis.

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:

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

PCDCharly · 18.05.2004

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.

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

Thx Matjes! :-*

Matjes · 19.05.2004

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 &amp; : &amp; 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) &amp; _
                          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 &lt;> 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 &lt;> 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) &amp; _
                          Right(s_orgtext, Len(s_orgtext) - pos2)
              pos1 = pos2 + 1-> nach pos2 weitersuchen
        End If
      End If
    Loop While (pos1 &lt;> 0)
  Next
End Sub

Trispac · 19.05.2004

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

PCDCharly · 20.05.2004

Trispac schrieb:
Jedoch bin ich immer wieder von den Programmiertalenten beeindruckt.

Na ich erst, zumal ich ohne diese Talente an meinen 27.000 zu bearbeitenden Zellen->ne Weile gesessen hätte.

8)

PCDjoe · 21.05.2004

Ola,

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

Excel Zelleninhalte automatisch editieren/löschen

PCDCharly

PCDCharly

Matjes

Trispac

PCDCharly

PCDjoe

Excel Zelleninhalte automatisch editieren/löschen

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums