08.07.2020, 09:17
Guten Tag liebe VBA´ler,
ich bringe dabei aus einer Excel Datei bestimmte Spalten in eine andere Excel Datei einzufügen.
folgender Code:
Nun möchte ich, dass in der anderen Datei "Aushang_VC" die Spalten automatisch auf autobreite gestellt werde.
meine Recherche ergab diesen Code:
ABER
es passiert gar nichts. Es kann sein, dass ich in die falsche Stelle eingecoded habe.
kann mir jemand Unterstützung leisten?
ich bringe dabei aus einer Excel Datei bestimmte Spalten in eine andere Excel Datei einzufügen.
folgender Code:
Code:
Option Explicit '3.12.2018 Mitarbeiterplan Master Versuch
Const UserPfad = "F:\2. Poolordner Aurelium\880_Allgemein\1. Markt und Interessenten\1. Interessenten\1. Aktuell\10. Vital Convenience\2. Personalplanung\Aushang_VC.xlsx"
Sub Daten_inAushang_kopieren()
Dim WB As Workbook, StZett As Object
Dim Sht As Worksheet, Blatt As String
On Error GoTo openErr 'Open Fehler
Application.ScreenUpdating = False
Application.Calculation = xlManual
neu: 'Neustart bei Open Fehler
Set WB = Workbooks("Aushang_vc.xlsx")
On Error Resume Next
Blatt = ThisWorkbook.Worksheets("Plan VC YF").[C1].Value
'Prüfung ob Blatt vorhanden, sonst erstellen
If IsMissing(WB.Worksheets(Blatt)) Then
WB.Worksheets.Add before:=Worksheets(1)
WB.Worksheets(1).Name = Blatt
Err = 0 'Err Nummer löschen
End If
Set StZett = WB.Worksheets(Blatt) 'Zieltabelle
On Error GoTo Fehler 'sonstige Fehler
With ThisWorkbook.Worksheets("Plan VC YF")
.Range("A1:A25").Font.Size = 16
.Range("C1:D25").Font.Size = 16
.Range("F1:F25").Font.Size = 16
.Range("H1:I25").Font.Size = 16
.Range("K1:K25").Font.Size = 16
.Range("M1:N25").Font.Size = 16
'Bereiche (B2:G32) nur Werte aus PlanHF kopieren
'** Range mit Punkt davor bezieht sich auf die With Klammer!!
.Range("A1:A25").Copy 'Quelltabelle kopieren
StZett.Range("A1").PasteSpecial Paste:=xlValues
StZett.Range("A1").PasteSpecial Paste:=xlPasteFormats
.Range("C1:D25").Copy 'Quelltabelle kopieren
StZett.Range("B1").PasteSpecial Paste:=xlValues
StZett.Range("B1").PasteSpecial Paste:=xlPasteFormats
'nur Werte in Zieltabelle einfügen = xlPasteValues
.Range("F1:F25").Copy 'Werte aus J2:N32 kopieren
StZett.Range("D1").PasteSpecial xlPasteValues
StZett.Range("D1").PasteSpecial Paste:=xlPasteFormats
.Range("H1:I25").Copy 'Werte aus R2:Y32 kopieren
StZett.Range("E1").PasteSpecial xlPasteValues
StZett.Range("E1").PasteSpecial Paste:=xlPasteFormats
.Range("K1:K25").Copy 'Werte aus R2:Y32 kopieren
StZett.Range("G1").PasteSpecial xlPasteValues
StZett.Range("G1").PasteSpecial Paste:=xlPasteFormats
.Range("M1:N25").Copy 'Werte aus R2:Y32 kopieren
StZett.Range("H1").PasteSpecial xlPasteValues
StZett.Range("H1").PasteSpecial Paste:=xlPasteFormats
'Einzelzellen B1,C1 mit Werte aus PlanHF laden
Application.Calculation = xlAutomatic
StZett.Activate '** kann gelöscht werden !!
Application.ScreenUpdating = True
MsgBox "Alles fehlerfrei kopiert"
WB.Save 'Stundenzettel speichern
'Stundenzettel schliessen wäre WB.Close
End With
Exit Sub
openErr: 'Stundenzettel nicht geöffnet!
Workbooks.Open Filename:=UserPfad
If ActiveWindow.Caption = "Aushang_VC.xlsx" Then
ThisWorkbook.Activate: GoTo neu 'Neustart
End If
Application.Calculation = xlAutomatic
MsgBox "Fehler: Aushang konnte nicht geöffnet werden!"
Exit Sub
Fehler: 'unerwartete Fehlermeldung
Application.Calculation = xlAutomatic
MsgBox "unerwarteter Fehler: " & Chr(10) & Error()
End Submeine Recherche ergab diesen Code:
Code:
Columns("A:I").EntireColumn.AutoFites passiert gar nichts. Es kann sein, dass ich in die falsche Stelle eingecoded habe.
kann mir jemand Unterstützung leisten?