Kopie von Dateien ohne Makros und Kommentare

nok106 · 21.01.2007

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:\ &amp; Left(.Name, Len(.Name) - 4) &amp; _
     Format(Now, _DD.MM.YY_hhmmss) &amp; .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

Matjes · 21.01.2007

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) &amp; _
                  Format(Now(), yyyymmdd_hhnnss) &amp; .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

nok106 · 22.01.2007

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 !!!!!!!!!

Matjes · 22.01.2007

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

nok106 · 26.01.2007

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

Matjes · 26.01.2007

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) &amp; _
                  Format(Now(), yyyymmdd_hhnnss) &amp; .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 &lt;> 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) &amp; : &amp; ly).Delete
    
   ->alle Zeilen oberhalb vom DB löschen
    lx = r.Row
    If lx > 1 Then ws.Rows(1 &amp; : &amp; (lx - 1)).Delete
    
    Application.CutCopyMode = False
    ws.Activate
    ws.Range(A1).Select
    Application.ScreenUpdating = True
    
    Set r = Nothing
  End If
End Sub

nok106 · 27.01.2007

Hallo Matjes

Perfekt !!!!!!!

Danke

Gruß Odje

Kopie von Dateien ohne Makros und Kommentare

nok106

Matjes

nok106

Matjes

nok106

Matjes

nok106

Kopie von Dateien ohne Makros und Kommentare

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums