Word Macro Problem

Dieses Thema Word Macro Problem im Forum "Microsoft Office Suite" wurde erstellt von Dindel, 23. Aug. 2006.

Thema: Word Macro Problem Hallo erstmal erstmal Kompliment an das Forum gute Sache das ich habe folgendes Problem wir haben in der Firma...

  1. Hallo erstmal

    erstmal Kompliment an das Forum gute Sache das
    ich habe folgendes Problem

    wir haben in der Firma mehrere Ordner mit vielen Word-Dateien.
    in diesen Dateien ist jeweils eine Tabelle der gleichen Form (gleiche Überschriften)
    nun soll in allen Dateien eine (immer die selbe) Spalte gelöscht werden.

    Frage 1.
    Geht das mit einem Macro ?
    Frage 2.
    Kann man das Macro dann auf alle Dateien in einem Ordner gleichzeitig anwenden?
    Frage 3.
    Wenn ja wie :) ?

    Danke für die Hilfe in voraus

    Gruß
    Dindel

    P.S.
    Rechtschreibefehler sind zur Belustigung anderer
     
  2. Hallo Dindel,

    zu
    JA  ;D
    einzieg Schwierigkeit wären verbundene Zellen
    zu
    JA
    Einschränkung: nacheinander, aber in einem Rutsch  ;D
    zu
    Da wird es schon schwierig, da ich die Datei(en) nicht sehe.
    Vielleicht kannst Du mir den Teil mit der Tabelle mit 1 -2 Absätzen davor und dahinter schicken ? Dann schau ich mir das mal an.

    Also schauen wir erstmal, ob man das auf eine Datei anwenden kann ?

    Das mit der gleichen Überschrift ist schon ganz gut.

    Die nachfolgenden Schritte sollte das Makro ausführen

    a) Datei öffnen
    b) Überschrift suchen (eventuell mehrere Fundorte behandeln)
    c) vorhandene Tabelle untersuchen, welche die nächste zur Überschrift ist. Diese als Kandidat ansehen.
    d) Wenn ein Tabellen-Kandidat vorliegt, weiter Prüfungen
    - Tabellenüberschriften
    - Anzahl Spalten
    - Anzahl Zeilen
    - ...
    so daß man sicher sein kann, daß es eine gesuchte Tabelle ist.

    d) in Protokolldatei Fundort protokollieren (Datei, Seite)
    e) Sicherung der Datei anlegen
    f) in Protokolldatei Sicherung protokollieren (Datei)
    g)  Spalte in Tatsächlicher Datei löschen
    h)  in Protokolldatei Spaltenlöschung protokollieren

    Das kann man dann mit einem übergeordneten Makro auf ein Verzeichnis und seine Unterverzeichnisse auf alle enthaltenen Worddateien loslassen.
    (Vielleicht gibt es ja noch Namenseinschränkungen bei der Dateisuche.

    Gruß Matjes :)

    ps: gibt es noch Paßwörter, Schreibschutz ... auf den Dateien


     
     
  3. Hallo

    erstmal danke für die Antwort
    klingt ja doch komplizierter als ich dachte

    ob ich dir Auszüge schicken kann muss ich mich erstmal absichern ;) du weist schon ;)

    verbunden sind da keine Zellen einfach Tabellen

    dein Konzept klingt aber gut ! danke !

    Passwörter und so sind da denk ich nicht gesetzt

    Ich werd mal schauen ob ich dir da was schicken kann
    und dann sehen wir weiter

    Danke auf jeden Fall schon mal für den Ansatz

    Gruß
    Dindel
     
  4. Hallo Dindel,

    ich hab dir mal einen Prototypen für eine Testdatei mit einer Tabelle zusammengestellt.

    Testdatei: zu suchende Überschrift und Spaltenüberschriften der Tabelle siehe Konstanten am Anfang des Makros.

    Gruß Matjes :)
    Code:
    Option Explicit
     -><<< A N P A S S E N >>>
     ->zu suchende Datei-Endung
      Const cDATEIENDUNG = .doc
     ->Kennzeichen zum finden der Tabelle
      Const cTXT_UEBERSCHRIFT = Die ist meine gesuchte Ueberschrift
     ->Verifizierung der der Überschrift folgenden Tabelle durch
      Const cTAB_UEBERSCHRIFT_SP1 = Datum
      Const cTAB_UEBERSCHRIFT_SP2 = Wertgegenstand
      Const cTAB_UEBERSCHRIFT_SP3 = Status
      Const cTAB_UEBERSCHRIFT_SP4 = Schätzpreis
      Const cTAB_UEBERSCHRIFT_SP5 = Interessent
      Const cTAB_ANZSPALTEN = 5
     ->zu löschende Spalte
      Const cTAB_ZULOESCHENDESPALTE = 3
     -><<< A N P A S S E N   E N D E >>>
    
    Sub Word_AlleFilesImDirectoryUndSubDirectoryBearbeiten()
      
     ->Bearbeitet alle Files im Directory und Subdirectories,
     ->die dem Filetyp msoFileTypeWordDocuments entsprechen
     ->und die Endung *.doc haben.
     ->
     ->Bearbeitung eines Files
     ->a) Datei öffnen
     ->b) Überschrift suchen (eventuell mehrere Fundorte behandeln)
     ->c) vorhandene Tabelle untersuchen, welche die nächste zur Überschrift ist.
     ->   Diese als Kandidat ansehen.
     ->d) Wenn ein Tabellen-Kandidat vorliegt, weiter Prüfungen
     ->- Tabellenüberschriften
     ->- Anzahl Spalten
     ->es kann noch mehr geprüft werden
     ->e) Sicherung der Datei anlegen (Dateiname um _SAVEyyyymmdd erweitern)
     ->g) Spalte in tatsächlicher Datei löschen
     ->h)   'Datei speichern
     ->
     -> Bearbeitung, Veränderungen und Fehler werden in der Protokoll-Datei festgehalten
     ->
    
      Const c_LOGFILE = Protokolldatei.txt
      
      Dim fileNum_Protokolldatei As Integer, s_Protokoll_Fullname As String
      Dim sFullDateiName As String, sPfad As String, sDateifilter As String
      Dim x As Long, attr As Integer
      
     ->Pfad und zu suchende Datei-Endung
      sPfad = ThisDocument.Path
      sDateifilter = *.doc
      
     ->Protokolldatei öffen
      s_Protokoll_Fullname = ThisDocument.Path & Application.PathSeparator & c_LOGFILE
      fileNum_Protokolldatei% = FreeFile()
      Open s_Protokoll_Fullname For Append As fileNum_Protokolldatei
      Print #fileNum_Protokolldatei, String(80, *)
      Print #fileNum_Protokolldatei, String(3, *) & Bearbeitung vom  & Format(Now(), yyyy.mm.dd hh:nn)
      Print #fileNum_Protokolldatei, String(80, *)
      
     ->Alle Files suchen und bearbeiten
      With Application.FileSearch
          .NewSearch
          .LookIn = sPfad
          .SearchSubFolders = True
          .MatchTextExactly = False
          .FileType = msoFileTypeWordDocuments
          If .Execute() > 0 Then
            For x = 1 To .FoundFiles.Count
              If LCase(Right(.FoundFiles(x), Len(cDATEIENDUNG))) = _
                 LCase(cDATEIENDUNG) Then                   'nur Dateien mit gesuchter Datei-Endung
                If Left(.FoundFiles(x), 1) <> ~ Then     ->temporäre files ausschliessen
                  If LCase(.FoundFiles(x)) <> _
                     LCase(ThisDocument.FullName) Then     ->die Makro-Datei ausschliessen
                    attr = GetAttr(.FoundFiles(x))
                    If 0 <> (attr And vbReadOnly) Then     ->Dateischreibschutz ?
                     ->Schreibschutz protokollieren
                      Print #fileNum_Protokolldatei, FEHLER: Datei-Schreibschutz & .FoundFiles(x)
                    Else
                     ->Datei bearbeiten
                      sFullDateiName = .FoundFiles(x)
                      Call Word_TabelleSpalteLoeschen_EineDatei(fileNum_Protokolldatei, sFullDateiName)
                    End If
                  End If
                End If
              End If
              DoEvents->damit die Nachrichtenschlange abgearbeitet werden kann
            Next
          End If
      End With
      
     ->Protokolldatei schliessen
      Close fileNum_Protokolldatei
      MsgBox Protokoll-Datei:  & s_Protokoll_Fullname
    End Sub
    
    Sub Word_TabelleSpalteLoeschen_EineDatei(fileNum_Protokolldatei As Integer, _
                                             sFullDateiName As String)
    
      Dim doc As Document, t As Table
      Dim sFullDateiName_Save As String, sDateiEndung As String
      Dim ues() As Long, uesCnt  As Long->Fundstellen Überschrift
      Dim x As Long, tabInd As Long
      
      Application.StatusBar = sFullDateiName
      
     ->Dateiname protokollieren
      Print #fileNum_Protokolldatei, String(3, *) & Format(Now(), yyyymmdd_hh:nn:ss ) & String(25, *)
      Print #fileNum_Protokolldatei, sFullDateiName
      
     ->a) Datei öffnen
      On Error Resume Next
      Set doc = Documents.Open(FileName:=sFullDateiName)
      If Err.Number <> 0 Then
        Err.Clear: On Error GoTo 0
        Print #fileNum_Protokolldatei, FEHLER: Datei konnte nicht geöffnet werden.
        GoTo AUFRAEUMEN
      End If
      
     ->b) Überschrift suchen (eventuell mehrere Fundorte behandeln)
      Call UeberschriftSuchen(doc, cTXT_UEBERSCHRIFT, ues(), uesCnt)
      If uesCnt = 0 Then
        Print #fileNum_Protokolldatei, Überschrift nicht enthalten.
        GoTo AUFRAEUMEN
      End If
      If uesCnt > 1 Then
        Print #fileNum_Protokolldatei, FEHLER: Überschrift mehrmals enthalten.
        GoTo AUFRAEUMEN
      End If
    
     ->c) vorhandene Tabelle untersuchen, welche die nächste zur Überschrift ist. Diese als Kandidat ansehen.
      Call NaechsteTabelleSuchen(doc, tabInd, ues(1))
      If tabInd = 0 Then
        Print #fileNum_Protokolldatei, keine passende Tabelle enthalten.
        GoTo AUFRAEUMEN
      End If
      
     ->d) Wenn ein Tabellen-Kandidat vorliegt, weiter Prüfungen
      Set t = doc.Tables(tabInd)
     ->- Tabellenüberschriften
     ->- Anzahl Spalten
     ->es kann noch mehr geprüft werden
     ->(-2 wegen CRLF am Textende)
      If Not ( _
        (t.Columns.Count = cTAB_ANZSPALTEN) And _
        (Left(t.Cell(1, 1).Range.Text, Len(t.Cell(1, 1).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP1) And _
        (Left(t.Cell(1, 2).Range.Text, Len(t.Cell(1, 2).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP2) And _
        (Left(t.Cell(1, 3).Range.Text, Len(t.Cell(1, 3).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP3) And _
        (Left(t.Cell(1, 4).Range.Text, Len(t.Cell(1, 4).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP4) And _
        (Left(t.Cell(1, 5).Range.Text, Len(t.Cell(1, 5).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP5) _
       ) Then
        Print #fileNum_Protokolldatei, keine passende Tabelle enthalten.
        GoTo AUFRAEUMEN
      End If
      Set t = Nothing
      Print #fileNum_Protokolldatei, passende Tabelle gefunden.
        
     ->e) Sicherung der Datei anlegen (Dateiname um _SAVEyyyymmdd erweitern)
      sDateiEndung = 
      For x = Len(sFullDateiName) To 1 Step -1
        If Mid(sFullDateiName, x, 1) = . Then
          sDateiEndung = Right(sFullDateiName, Len(sFullDateiName) - x + 1)
        ElseIf Mid(sFullDateiName, x, 1) = Application.PathSeparator Then
          Exit For
        End If
      Next
      sFullDateiName_Save = Left(sFullDateiName, Len(sFullDateiName) - Len(sDateiEndung)) & _
                           _SAVE & Format(Now, yyyymmdd) & sDateiEndung
      doc.SaveAs FileName:=sFullDateiName_Save
      doc.Close
      Set doc = Documents.Open(FileName:=sFullDateiName)
     ->f) in Protokolldatei Sicherung protokollieren (Datei)
      Print #fileNum_Protokolldatei, SICHERUNG:  & sFullDateiName_Save
    
     ->g)  Spalte in Tatsächlicher Datei löschen
      Set t = doc.Tables(tabInd)
      On Error Resume Next
      t.Columns(cTAB_ZULOESCHENDESPALTE).Delete
      If Err.Number <> 0 Then
        Err.Clear: On Error GoTo 0
        Print #fileNum_Protokolldatei, FEHLER: Spalte konnte nicht gelöscht werden.
        GoTo AUFRAEUMEN
      End If
      On Error GoTo 0
     ->h)  in Protokolldatei Spaltenlöschung protokollieren
      Print #fileNum_Protokolldatei, Spalte gelöscht
    
     ->Datei speichern
      doc.Save
      Print #fileNum_Protokolldatei, Datei gespeichert
      
    AUFRAEUMEN:
      On Error Resume Next
      doc.Close Savechanges:=wdDoNotSaveChanges
      Err.Clear: On Error GoTo 0
      Application.StatusBar = 
      Set doc = Nothing: Set t = Nothing
    End Sub
    Private Function NaechsteTabelleSuchen(doc As Document, tabInd As Long, StartUeberschrift As Long)
      Dim tabStart As Long, x As Long
      tabStart = 2147483647->maximum long
      tabInd = 0
      For x = 1 To doc.Tables.Count
        With doc.Tables(x).Range
          If .start < tabStart And .start > StartUeberschrift Then tabStart = .start: tabInd = x
        End With
      Next
    
    End Function
    
    Private Function UeberschriftSuchen(doc As Document, sUeberschrift As String, ues() As Long, uesCnt As Long)
     ->b) Überschrift suchen (eventuell mehrere Fundorte behandeln)
      uesCnt = 0: ReDim ues(1 To 1)
      With doc.Content.Find
          .ClearFormatting
          .Forward = True
          .Format = False
          .MatchCase = True
          .Wrap = wdFindStop
          .Text = sUeberschrift
          Do While .Execute() = True
            With .Parent
              uesCnt = uesCnt + 1: ReDim Preserve ues(1 To uesCnt)
              ues(uesCnt) = .start
            End With
          Loop
      End With
    End Function
     
Die Seite wird geladen...

Word Macro Problem - Ähnliche Themen

Forum Datum
MacroButton in Word-Dokument / Autotext Windows XP Forum 22. Dez. 2002
Welches ist das letzte kaufbare Office und Fehler beim Scrollen in Word: Text verdoppelt sich Microsoft Office Suite 14. Juli 2016
Word und Powerpoint hakeln. Filme abspielen führt zu Aufhängen Windows 10 Forum 17. Dez. 2015
Webhosting für WordPress auf Windows Server Webentwicklung, Hosting & Programmierung 21. Juli 2015
Öffnen mit Doppelklick funktioniert bei Word u. Excel Dateien nichtmehr Microsoft Office Suite 10. Feb. 2015