Live-Forum - Die aktuellen Beiträge
Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
VBA Blatt kopieren
04.05.2019 20:03:36
Michael
Hallo zusammen,
folgenden Code würde ich gerne dahingehend ändern, das als Dateiname, der Name eingesetzt wird, der in Zelle B10 steht.
Viele Grüße
Michael
Sub BlattKopieren()
Application.ScreenUpdating = False
With ThisWorkbook.ActiveSheet
.Visible = xlSheetVisible
.Copy
End With
With ActiveWorkbook
With .Worksheets(1).Cells
.Copy
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Cells(1).Select
End With
.SaveAs ThisWorkbook.Path & "\" & "Test.xls", xlOpenXMLWorkbook 'Dateinamen anpassen *** _
_
_
_
End With
End Sub

26
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA Blatt kopieren
04.05.2019 20:06:01
Hajo_Zi
.SaveAs ThisWorkbook.Path & "\" & Range("10")& ".xls", xl,,,

Beiträge von Werner, Luc, robert, J.O.Maximo und folgende lese ich nicht.
Die Beiträge werden auch ignoriert, es erfolgt keine Antwort.
AW: VBA Blatt kopieren
04.05.2019 20:40:39
Michael
Hallo Hajo,
mit B10 klappts wunderbar!
Vielen Dank
AW: VBA Blatt kopieren
05.05.2019 08:42:52
Michael
Guten Morgen zusammen,
ich habe mal wieder erfolglos versucht den Code so anzupassen, so dass vorher eine Abfrage kommt, ob die Datei in dem Ordner schon vorhanden ist.
Klappt aber nicht...…
Weiter bekomme ich immer eine Meldung bei der Ausführung des Makros:
Die folgenden Features können in Arbeitsmappen ohne Makros nicht gespeichert werden.
Zum speichern einer Datei mit diesen Features, klicken Sie auf Nein.
Wählen Sie dann einen Dateityp mit aktivierten Makro in der Liste Dateityp aus.
Klicken Sie auf Ja, um die Datei als Arbeitsmappe ohne Makros zu speichern.
Wenn ich die Meldung mit Ja bestätige, wird die Datei angelegt.
Bestätige ich diese mit Nein, bekomme ich einen Laufzeitfehler 1004.
VB Projekte und XLM Blätter können in einer Arbeitsmappe ohne Makros nicht gespeichert werden.
Ich bin leider mal wieder auf Hilfe angewiesen :-(
Sub BlattKopieren()
If ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsx" = "" Then
MsgBox "Datei existiert bereits!"
Exit Sub
Else
Application.ScreenUpdating = False
With ThisWorkbook.ActiveSheet 'BlattName anpassen **********
.Visible = xlSheetVisible
.Copy
End With
With ActiveWorkbook
With .Worksheets(1).Cells
.Copy
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Cells(1).Select
End With
.SaveAs ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsx",  _
xlOpenXMLWorkbook 'Dateinamen anpassen *****
End With
ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
Range("A10").Select
ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
Selection.Delete
End If
End Sub

Anzeige
AW: VBA Blatt kopieren
05.05.2019 08:53:20
Sepp
Hallo Michael,
ungetestet!
Sub BlattKopieren()
  Dim strFileName As String
  
  strFileName = ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsm"
  
  If Dir(strFileName, vbNormal) <> "" Then
    MsgBox "Datei existiert bereits!"
  Else
    Application.ScreenUpdating = False
    With ThisWorkbook.ActiveSheet 'BlattName anpassen ********** 
      .Visible = xlSheetVisible
      .Copy
    End With
    With ActiveWorkbook
      With .Sheets(1)
        .UsedRange = .UsedRange.Value
        .Cells(1, 1).Select
        .Shapes("Rectangle 1").Delete
      End With
      Call .SaveAs(Filename:=strFileName, FileFormat:=xlOpenXMLWorkbookMacroEnabled)
    End With
  End If

ErrorHandler:
  Application.ScreenUpdating = True
End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0


Anzeige
AW: VBA Blatt kopieren
05.05.2019 09:06:32
Hajo_Zi
sehe ich es falsch das Du nicht prüfst ob Datei vorhanden? Ich würde dafür
If Dir(Pfad\Datei) "" then
benutzen
Gruß Hajo
AW: VBA Blatt kopieren
05.05.2019 11:19:15
Michael
Hallo Hajo,
habe es jetzt so versucht, die Abfrage klappt aber nicht. Er will die Datei trotzdem anlegen.
Wenn diese vorhanden ist bekomme ich einen Laufzeitfehler. Ich möchte aber, wenn die Datei mit dem Namen vorhanden ist, dass die Prozedur abgebrochen wird.
Gruß
Michael
Sub BlattKopieren()
If Dir("C:Users \ mkmic \ Documents \ DTV \ Buchf?hrung \ Buchf?hrung" & "\" & Range("B8") &  _
Range("B10") & ".xlsx")  "" Then
MsgBox "Datei existiert bereits!"
Else
Application.ScreenUpdating = False
With ThisWorkbook.ActiveSheet 'BlattName anpassen **********
.Visible = xlSheetVisible
.Copy
End With
With ActiveWorkbook
With .Worksheets(1).Cells
.Copy
.PasteSpecial xlPasteValues
Application.CutCopyMode = False
.Cells(1).Select
End With
.SaveAs ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsx",  _
xlOpenXMLWorkbook 'Dateinamen anpassen *****
End With
ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
Range("A10").Select
ActiveSheet.Shapes.Range(Array("Rectangle 1")).Select
Selection.Delete
End If
End Sub

Anzeige
Meinen Code probiert? o.T.
05.05.2019 11:37:58
Sepp
AW: Meinen Code probiert? o.T.
05.05.2019 12:49:46
Michael
Hallo Sepp,
dein Code klappt!
Vielen Dank
Kann man das aber noch 1:1 kopieren?
Die Tabelle verliert so ihr Format.
Viele Grüße
Michael
AW: Meinen Code probiert? o.T.
05.05.2019 12:55:31
Sepp
Hallo Michael,
also mein Code verändert nichts an der Formatierung der Tabelle!
AW: Meinen Code probiert? o.T.
05.05.2019 13:33:02
Michael
Hallo Sepp,
der Inhalt der Tabelle wird kopiert aber die Tabelle selbst nicht. Das heißt ich muss wieder von Hand eine Tabellen einfügen.
Gruß
Michael
AW: Meinen Code probiert? o.T.
05.05.2019 13:33:04
Michael
Hallo Sepp,
der Inhalt der Tabelle wird kopiert aber die Tabelle selbst nicht. Das heißt ich muss wieder von Hand eine Tabellen einfügen.
Gruß
Michael
Glaub ich nicht!
05.05.2019 13:34:43
Sepp
Hallo Michael,
es wird aus der Tabelle eine neue Datei erstellt, da geht nicht verloren.
Lade eine Beispieldatei mit dem zu kopierenden Tabellenblatt und deinen gesamten Code hoch.
Anzeige
AW: Glaub ich nicht!
05.05.2019 17:07:17
Sepp
Hallo Michael,
dei Formate gingen nicht verloren, aber leider übernimmt XL die Theme-Colorschmes nicht automatisch von der Ausgangsdatei.
Die Datei wird jetzt erstellt, der VBA-Code entfernt, die Farben richtig übernommen und als xlsx gespeichert.
Sub BlattKopieren()
  Dim strFileName As String
  
  strFileName = ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsx"
  
  If Dir(strFileName, vbNormal) <> "" Then
    MsgBox "Datei existiert bereits!"
  Else
    With Application
      .ScreenUpdating = False
      .EnableEvents = False
      .DisplayAlerts = False
      .Calculation = xlCalculationManual
    End With

    ThisWorkbook.ActiveSheet.Copy

    With ActiveWorkbook
      With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule
        Call .DeleteLines(1, .CountOfLines)
      End With
      With .Sheets(1)
        .ListObjects(1).Unlist
        .UsedRange = .UsedRange.Value
        .Cells(1, 1).Select
        .Shapes("Rectangle 1").Delete
      End With
      Call .ApplyTheme(ThisWorkbook.FullName)
      Call .SaveAs(Filename:=strFileName, FileFormat:=xlOpenXMLWorkbook)
      Call .Close(True)
    End With
  End If

  'Kill strColorSchme 
  
ErrorHandler:
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
  End With
End Sub


VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0


Anzeige
AW: Glaub ich nicht!
05.05.2019 17:33:30
Michael
Hallo Sepp,
bekomme folgende Fehlermeldung: Laufzeitfehler 1004
Der programmatische Zugriff auf Visual Basic Projekt ist nicht sicher.
Gruß
Michael
AW: Glaub ich nicht!
05.05.2019 17:42:15
Michael
Hallo Sepp,
Fehler ist behoben! War eine Einstellungssache.
Jetzt fehlt noch das die Werte anstatt der Formeln kopiert werden.
Vielen ´Dank nochmal.
Viele Grüße
Michael
AW: Glaub ich nicht!
05.05.2019 17:34:57
Michael
Hallo Sepp,
noch was, ich möchte das nur die Werte kopiert werden und nicht die Formeln.
AW: Glaub ich nicht!
05.05.2019 17:44:02
Sepp
Hallo Michael,
es werden nur die Werte kopiert bzw. nach dem Kopieren werden die Formeln in Werte umgewandelt.
Zum Laufzeitfehler: Du musst in XL in den Optionen > Trust Center > Einstellungen für das Trust Center > Makroeinstellungen den Zugriff auf das VBA-Projektmodell erlauben.
Anzeige
AW: Glaub ich nicht!
05.05.2019 18:17:42
Michael
Hallo Sepp,
stimmt, ist mir jetzt auch aufgefallen.
Was aber noch ist, wenn ich die kopierte Datei öffne wird versucht Verknüpfungen zu aktualisieren, Wie kann ich das verhindern?
AW: Glaub ich nicht!
05.05.2019 18:33:26
Sepp
Hallo Michael,
Sub BlattKopieren()
  Dim strFileName As String, varLinks As Variant, lngindex As Long
  
  On Error GoTo ErrorHandler
  
  strFileName = ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsx"
  
  If Dir(strFileName, vbNormal) <> "" Then
    MsgBox "Datei existiert bereits!"
  Else
    With Application
      .ScreenUpdating = False
      .EnableEvents = False
      .DisplayAlerts = False
      .Calculation = xlCalculationManual
    End With

    ThisWorkbook.ActiveSheet.Copy

    With ActiveWorkbook
      With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule
        Call .DeleteLines(1, .CountOfLines)
      End With
      With .Sheets(1)
        .ListObjects(1).Unlist
        .UsedRange = .UsedRange.Value
        .Cells(1, 1).Select
        .Shapes("Rectangle 1").Delete
      End With
      Call .ApplyTheme(ThisWorkbook.FullName)
      Call .SaveAs(Filename:=strFileName, FileFormat:=xlOpenXMLWorkbook)
      On Error Resume Next
      varLinks = .LinkSources(xlLinkTypeExcelLinks)
      For lngindex = 1 To Ubound(varLinks)
        Call .BreakLink(varLinks(lngindex), xlLinkTypeExcelLinks)
      Next
      Err.Clear
      On Error GoTo ErrorHandler
      Call .Close(True)
    End With
  End If
 
ErrorHandler:
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
  End With
End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0


Anzeige
AW: Glaub ich nicht!
05.05.2019 18:41:18
Michael
Hallo Sepp,
es wird immer noch versucht irgendwelche Verknüpfungen zu aktualisieren.
So kurz vorm Ziel :-)
Missetäter gefunden!
05.05.2019 18:56:03
Sepp
Hallo Michael,
jetzt sollte es endgültig klappen.
Sub BlattKopieren()
  Dim strFileName As String, varLinks As Variant, lngindex As Long
  
  'On Error GoTo ErrorHandler 
  
  strFileName = ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsx"
  
  If Dir(strFileName, vbNormal) <> "" Then
    MsgBox "Datei existiert bereits!"
  Else
    With Application
      .ScreenUpdating = False
      .EnableEvents = False
      .DisplayAlerts = False
      .Calculation = xlCalculationManual
    End With

    ThisWorkbook.ActiveSheet.Copy

    With ActiveWorkbook
      With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule
        Call .DeleteLines(1, .CountOfLines)
      End With
      With .Sheets(1)
        .ListObjects(1).Unlist
        .UsedRange = .UsedRange.Value
        On Error Resume Next
        .UsedRange.SpecialCells(xlCellTypeAllValidation).Validation.Delete
        Err.Clear
        On Error GoTo ErrorHandler
        .Cells(1, 1).Select
        .Shapes("Rectangle 1").Delete
      End With
      Call .ApplyTheme(ThisWorkbook.FullName)
      Call .SaveAs(Filename:=strFileName, FileFormat:=xlOpenXMLWorkbook)
      On Error Resume Next
      varLinks = .LinkSources(xlLinkTypeExcelLinks)
      For lngindex = 1 To Ubound(varLinks)
        Call .BreakLink(varLinks(lngindex), xlLinkTypeExcelLinks)
      Next
      Err.Clear
      On Error GoTo ErrorHandler
      Call .Close(True)
    End With
  End If
 
ErrorHandler:
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
  End With
End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0


Anzeige
AW: Missetäter gefunden!
05.05.2019 19:09:26
Michael
Hallo Sepp,
leider noch nicht ganz,
die Zahlen Formatierung ist noch nicht die richtige.
negative Werte werden in Klammern und rot so angezeigt (€724,29)
Ich möchte sie aber gerne als Währung -724,29€ in rot angezeigt bekommen. Sonst könnte die Formatierung zur Verwirrungen führen.
AW: Missetäter gefunden!
05.05.2019 19:31:43
Sepp
Hallo Michael,
deine Datei verhält sich bezüglich der Formate echt seltsam!
So sollte es klappen.
Sub BlattKopieren()
  Dim strFileName As String, varLinks As Variant, lngindex As Long
  
  'On Error GoTo ErrorHandler 
  
  strFileName = ThisWorkbook.Path & "\" & Range("B8") & Range("B10") & ".xlsx"
  
  If Dir(strFileName, vbNormal) <> "" Then
    MsgBox "Datei existiert bereits!"
  Else
    With Application
      .ScreenUpdating = False
      .EnableEvents = False
      .DisplayAlerts = False
      .Calculation = xlCalculationManual
    End With

    ThisWorkbook.ActiveSheet.Copy

    With ActiveWorkbook
      With .VBProject.VBComponents(.Sheets(1).CodeName).CodeModule
        Call .DeleteLines(1, .CountOfLines)
      End With
      With .Sheets(1)
        .ListObjects(1).Unlist
        .UsedRange = .UsedRange.Value
        On Error Resume Next
        .UsedRange.SpecialCells(xlCellTypeAllValidation).Validation.Delete
        Err.Clear
        On Error GoTo ErrorHandler
        .Cells(1, 1).Select
        .Shapes("Rectangle 1").Delete
        .Columns("B").NumberFormat = "#,##0.00 $;[Red] -#,##0.00 $"
        .Columns("L:M").NumberFormat = "#,##0.00 $;[Red] -#,##0.00 $"
      End With
      Call .ApplyTheme(ThisWorkbook.FullName)
      Call .SaveAs(Filename:=strFileName, FileFormat:=xlOpenXMLWorkbook)
      On Error Resume Next
      varLinks = .LinkSources(xlLinkTypeExcelLinks)
      For lngindex = 1 To Ubound(varLinks)
        Call .BreakLink(varLinks(lngindex), xlLinkTypeExcelLinks)
      Next
      Err.Clear
      On Error GoTo ErrorHandler
      Call .Close(True)
    End With
  End If
 
ErrorHandler:
  With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .DisplayAlerts = True
    .Calculation = xlCalculationAutomatic
  End With
End Sub

VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media

Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0


Anzeige
AW: Missetäter gefunden!
05.05.2019 19:38:29
Michael
Hallo Sepp,
ich bedanke mich vielmals bei Dir!!!
Vor allem für deine Geduld die Du mit mir hattest! :-)
Jetzt funktioniert alles wunderbar.
Ich wünsche Dir noch einen schönen Abend und das Du noch viele Anfänger hier glücklich machst.
Viele Grüße
Michael
AW: Missetäter gefunden!
07.05.2019 16:30:47
Michael
Hallo Sepp,
nachdem ich nochmal genauer hingeschaut habe, sind mir doch noch Fehler aufgefallen.
Ein gravierender Fehler ist, dass die Tabellenfunktion in der kopierten Tabelle nicht mehr vorhanden ist.
Weiter habe ich in Zelle B8 und B12 eine Standardzahl, die aber in € angezeigt wird.
Dann würde ich gerne, dass Objekte nicht mit kopiert werden.
Könntest Du vielleicht nochmal drüber schauen?
Viele Grüße
Michael

306 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige