Kopie von Dateien ohne Makros und Kommentare

Dieses Thema Kopie von Dateien ohne Makros und Kommentare im Forum "Microsoft Office Suite" wurde erstellt von nok106, 21. Jan. 2007.

Thema: Kopie von Dateien ohne Makros und Kommentare Hallo Excelfreunde ! Gibt es hierfür eine Lösung ? Weißt jemand wie ich den Druckbereich im folgenden Makro...

  1. Hallo Excelfreunde !

    Gibt es hierfür eine Lösung ?

    Weißt jemand wie ich den Druckbereich im folgenden Makro einbinden kann?

    Das Makro kopiert so wie es jetzt ist, das gesamte Arbeitsblatt, also auch die Druck-Buttons an der Seite und meine Kommentare.
    Da ich einige der Dateien an andere Users weiter gegeben will, möchte ich gerne, dass die Buttons und Kommentare nicht mit kopiert werden.

    Code:
    Sub DateiKopie()
         With ThisWorkbook
        .SaveCopyAs D:\ & Left(.Name, Len(.Name) - 4) & _
         Format(Now, _DD.MM.YY_hhmmss) & .xls
        End With
    End Sub
    Hat jemand eine Idee ob das geht und wenn ja - Wie ?

    Einstweilen herzlichen Dank an alle, die sich für mich bemühen.

    MfG Odje
     
  2. Hallo nok106,

    das könnte wie folgt aussehen. Bzgl. Code-Entfernen ist die->Microsoft Visual Basic for Applications Extensibility (5.3)' unter Verweise mit einzubinden.

    Gruß matjes :)
    Code:
    Option Explicit
    Sub DateiKopieSpeichern_OhneCodeButtonComment()
      Dim sFilenameFull As String
      
      sFilenameFull = Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 4) & _
                      Format(Now(), yyyymmdd_hhnnss) & .xls
      
      ThisWorkbook.SaveCopyAs Filename:=sFilenameFull
      
      Call CodeEntfernen(sFilenameFull)
      Call CommandButtonEntfernen(sFilenameFull)
      Call CommentsEntfernen(sFilenameFull)
    End Sub
    
    '*********************************************************************************
    Private Function CodeEntfernen(sFilenameFull As String)
    '*** !!!!  Microsoft Visual Basic for Applications Extensibility oder
    '*** !!!!  Microsoft Visual Basic for Applications Extensibility 5.3
    '*** !!!!  unter Extras-Verweis einbinden
    
      Dim Wb As Workbook, VBComp As VBComponent
      Dim x As Long
    
      Set Wb = Workbooks.Open(Filename:=sFilenameFull)
      For x = Wb.VBProject.VBComponents.Count To 1 Step -1
        Set VBComp = Wb.VBProject.VBComponents(x)
        If VBComp.Type = vbext_ct_StdModule Or _
           VBComp.Type = vbext_ct_ClassModule Or _
           VBComp.Type = vbext_ct_MSForm Then
          Wb.VBProject.VBComponents.Remove VBComp
        ElseIf VBComp.Type = vbext_ct_Document Then
         ->DieseArbeitsmappe und Tabellenblätter
          VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
        End If
      Next
      Wb.Close Savechanges:=True
    AUFRAEUMEN:
      Set Wb = Nothing: Set VBComp = Nothing
    End Function
    
    '*********************************************************************************
    Private Function CommandButtonEntfernen(sFilenameFull As String)
      
      Dim Wb As Workbook, ws As Worksheet
      Dim x As Long
      
      Set Wb = Workbooks.Open(Filename:=sFilenameFull)
      For Each ws In Wb.Worksheets
        For x = ws.OLEObjects.Count To 1 Step -1
          If ws.OLEObjects(x).progID = Forms.CommandButton.1 Then
            ws.OLEObjects(x).Delete
          End If
        Next
      Next
      Wb.Close Savechanges:=True
    AUFRAEUMEN:
      Set Wb = Nothing: Set ws = Nothing
    End Function
    
    '*********************************************************************************
    Private Function CommentsEntfernen(sFilenameFull As String)
      
      Dim Wb As Workbook, ws As Worksheet, bt As CommandButton
      Dim x As Long
      
      Set Wb = Workbooks.Open(Filename:=sFilenameFull)
      For Each ws In Wb.Worksheets
        ws.UsedRange.ClearComments
      Next
      Wb.Close Savechanges:=True
    AUFRAEUMEN:
      Set Wb = Nothing: Set ws = Nothing
    End Function
     
  3. Hallo Matjes,

    für deine Bemühungen besten Dank.

    Das Maskro hat noch eine kleine Macke und zwar in der letzen Function

    Beim Durchlauf kommt die Fehlermeldung,

    Fehler beim kompilieren:
    Benutzerdefinierter Typ nicht definiert


    Ich habe die Zeile gekennzeichnet mit->***........... und bis zum Fehler deaktiviert,

    Code:
    Private Function CommentsEntfernen(sFilenameFull As String)
      
      Dim Wb As Workbook, ws As Worksheet         '****, bt As CommandButton
      Dim x As Long
      
      Set Wb = Workbooks.Open(Filename:=sFilenameFull)
      For Each ws In Wb.Worksheets
        ws.UsedRange.ClearComments
      Next
      Wb.Close Savechanges:=True
    AUFRAEUMEN:
      Set Wb = Nothing: Set ws = Nothing
    End Function
    danach lief der Code insofern einwandfrei, dass die Kommentare in der Kopie gelöscht waren nur der Button war noch vorhanden.

    Weiterhin fehlt noch der konstante Speicherpfad (D:\).

    Darf ich nochmal um deine Hilfe bitten.

    MfG Odje

    PS.
    Das mit dem Speicherpfad ist erledig !!!!!!!!!
     
  4. Hallo nok106,

    das ist noch irgend ein Rest vom Editieren.
    Code:
    ->****, bt As CommandButton
    Hast Du genau richtig erkannt und auskommentiert.
    Tschuldige, aber ich bin im Augenblick nicht so richtig fit.

    Gruß Matjes :)
     
  5. Hallo Matjes,

    Kann man das Makro auch so umbauen, dass nur der Druckbereich des aktiven Blattes in eine neue Datei geschrieben wird ?

    Wenn die Möglichkeit gegeben ist, kann ich dann nochmal deine Hilfe in Anspruch nehmen !  :)

    Gruß Odje
     
  6. Dann probier mal diese Version  ;)

    Gruß Matjes :)
    Code:
    Option Explicit
    Sub DateiKopieSpeichern_OhneCodeButtonComment()
      Dim wb As Workbook, ws As Worksheet
      Dim sFilenameFull As String, sAktName As String
      
      sFilenameFull = Left(ThisWorkbook.FullName, Len(ThisWorkbook.FullName) - 4) & _
                      Format(Now(), yyyymmdd_hhnnss) & .xls
      
      ThisWorkbook.SaveCopyAs Filename:=sFilenameFull
      
      sAktName = ActiveSheet.Name
      
      Set wb = Workbooks.Open(Filename:=sFilenameFull)
      
     ->alle Blätter bis auf das aktuelle löschen
      Application.DisplayAlerts = False
      For Each ws In wb.Worksheets
        If ws.Name <> sAktName Then ws.Delete
      Next
      Application.DisplayAlerts = True
      
      Set ws = wb.Worksheets(1)
      
      Call AllesAusserDruckbereichLoeschen(ws)
      Call CodeEntfernen(wb)
      Call CommandButtonEntfernen(ws)
      ws.UsedRange.ClearComments
      
      wb.Close Savechanges:=True
    End Sub
    
    '*********************************************************************************
    Private Function CodeEntfernen(wb As Workbook)
    '*** !!!!  Microsoft Visual Basic for Applications Extensibility oder
    '*** !!!!  Microsoft Visual Basic for Applications Extensibility 5.3
    '*** !!!!  unter Extras-Verweis einbinden
    
      Dim VBComp As VBComponent
      Dim x As Long
    
      For x = wb.VBProject.VBComponents.Count To 1 Step -1
        Set VBComp = wb.VBProject.VBComponents(x)
        If VBComp.Type = vbext_ct_StdModule Or _
           VBComp.Type = vbext_ct_ClassModule Or _
           VBComp.Type = vbext_ct_MSForm Then
          wb.VBProject.VBComponents.Remove VBComp
        ElseIf VBComp.Type = vbext_ct_Document Then
         ->DieseArbeitsmappe und Tabellenblätter
          VBComp.CodeModule.DeleteLines 1, VBComp.CodeModule.CountOfLines
        End If
      Next
    AUFRAEUMEN:
      Set VBComp = Nothing
    End Function
    
    '*********************************************************************************
    Private Function CommandButtonEntfernen(ws As Worksheet)
      
      Dim x As Long
      
      For x = ws.OLEObjects.Count To 1 Step -1
        If ws.OLEObjects(x).progID = Forms.CommandButton.1 Then
          ws.OLEObjects(x).Delete
        End If
      Next
    End Function
    
    '*********************************************************************************
    
    Sub AllesAusserDruckbereichLoeschen(ws As Worksheet)
    
      Dim r As Range
      Dim sPrintArea As String
      Dim lx As Long, ly As Long, x As Long
      
      sPrintArea = ws.PageSetup.PrintArea
      
      If Not sPrintArea =  Then
        Set r = ws.Range(sPrintArea)
        
        Application.ScreenUpdating = False
        
       ->alle benutzen Spalten rechts vom DB löschen
        lx = r.Column + r.Columns.Count - 1
        ly = ws.UsedRange.Column + ws.UsedRange.Columns.Count - 1
        For x = lx + 1 To ly: ws.Columns(lx + 1).Delete: Next
        
       ->alle Spalten links vom DB löschen
        lx = r.Column
        For x = 1 To lx - 1: ws.Columns(1).Delete: Next
        
       ->alle benutzen Zeilen unterhalb vom DB löschen
        lx = r.Row + r.Rows.Count - 1
        ly = ws.UsedRange.Row + ws.UsedRange.Rows.Count - 1
        If ly > lx Then ws.Rows((lx + 1) & : & ly).Delete
        
       ->alle Zeilen oberhalb vom DB löschen
        lx = r.Row
        If lx > 1 Then ws.Rows(1 & : & (lx - 1)).Delete
        
        Application.CutCopyMode = False
        ws.Activate
        ws.Range(A1).Select
        Application.ScreenUpdating = True
        
        Set r = Nothing
      End If
    End Sub
     
  7. Hallo Matjes

    Perfekt !!!!!!!

    Danke

    Gruß Odje
     
Die Seite wird geladen...

Kopie von Dateien ohne Makros und Kommentare - Ähnliche Themen

Forum Datum
Dateien/Verzechnisse oberhalb 2 GigaByte lassen sich nicht vom WIN 7-System auf XP-Systeme kopieren/ Firewalls & Virenscanner 5. März 2011
Dateien von Linux nach Win7 kopiert... Probleme mit Sonderzeichen Windows 7 Forum 13. Jan. 2011
Kopieren von Dateien von externer Platte weigert sich Windows 7 Forum 21. Dez. 2010
Fehlermeldung beim Kopieren von Dateien Windows 7 Forum 28. März 2013
Dateien lassen sich nicht kopieren Windows 7 Forum 1. Feb. 2012