VBA+Schaltfläche um Bereich in andere Mappe einzufügen

[CHASiN1994]

Hi Leute,

ich würde gerne eure Hilfe annehmen für einen VBA Code und eine Schaltfläche, da ich mich mit VBA noch nicht wirklich auseinander gesetzt habe.

Es geht um eine Liste, die unsere Mitarbeiter täglich plant. Das Blatt was aus der Planung resultiert habe ich euch in den Anhang gehangen. Wie ihr seht sind in den Spalten
=UND(C;G;H;K;O;P;S;W;X;AA;AE;AF) Formeln hinterlegt. 
// Das könnte für das weitere Vorgehen evtl. wichtig sein.

Was ich nun möchte ist, dass per Knopfdruck auf eine Schaltfläche folgendes passiert:

1. Die Bereiche =UND(B2:G32;J2:N32;R2:V32;Z2:AD32) sollen in eine andere Mappe die da heißt "Stundenzettel HF" in A2:XX.. eingefügt werden (Einfügeoptionen = Werte) 
2. In "Stundenzettel HF" soll in A1 der Bereich B1 aus PlanHF eingefügt werden
3. In "Stundenzettel HF" soll in B1 der Bereich C1 aus PlanHF (Einfügeoptionen = Werte) eingefügt werden

Ich glaube die Schaltfläche kriege ich selber hin. also das wichtige wäre mir der Code.
Falls mir damit jemand helfen kann wäre ich sehr dankbar.

MfG

[Gast 123]

Hallo

die Beispieldatei mit lauffaehigem Makro zurück.  Eigenarbeit:  im Makro muss zum Öffnen der Datei "Stundenzettel" dein UserPfad angegeben werden.  Und im Makro unter:  Set StZett = WB.Worksheets(1)  ggf. die richtige Zieltabelle, zur Zeit das 1. Blatt in der Datei Stundenzettel.

Das Makro öffnet die Datei wenn sie nicht Offen ist, kopiert, und speichert und schliesst den Stundenzettel wenn das kopieren fehlerfrei funktioniert hat.  Laufzeitfehler wird auftreten wenn man versucht die Datei "Stundenzettel" mit einer falschen UserPfad Angabe zu Öffnen. Das kann ich nicht verhindern.  Dann muss man den VBA Editor Reseten.

Das Makro ist so einfach geschrieben das man leicht verstehen kann welche Bereiche ich kopiere, und unter welcher Zieladresse die Daten eingefügt werden.  Sollte der Bereich oder die Zieladresse nicht stimmen kann man es leicht selbst korrigieren und ggf. um weitere Bereich anassen.
 
Würde mich freuen wenn das Programm zufriedenstellen funktioniert.

mfg  Gast 123

[CHASiN1994]

Ja, danke erstmal vielmals. Es funktioniert in etwa so wie ich es mir vorgestellt habe. Habe die Verweise zu den korrekten Listen und den Hyperlink zum richtigen Pfad ebenfalls gemeistert.

Jetzt habe ich eben versucht sowohl die Werte als auch die Formatierung zu übernehmen. Habe dafür bei Google etwas gefunden. Ich denke aber da werden noch ein bis zwei fragen kommen. 
Zb würde ich gerne dass jedes Mal ein neues Tabellenplatt in stundenzettel  gür den Tag erstellt wird, der in c1 steht.


Aber ich bin dir so oder so erstmal ziemlich dankbar :)

[CHASiN1994]

so hier bin ich nochmal.

also funktioniert zunächst so wie ich es möchte inkl. die Formate und der richtige Bereich

Jetzt möchte ich gerne wenn ich auf die Schaltfläche drücke, dass in Stundenzettel.xlsx ein neues Tabellenblatt mit dem Datum aus PlanHF_Makro Zelle C1 als Tabellenblattname erstellt wird. in diesem Tabellenblatt soll nun wie bereits aktuell richtigerweise die Daten eingefügt werden.

ich hänge euch die Mappe mal dran:

MfG

[Gast 123]

Hallo

ich habe den Code um das einfügen einer neuen Tabelle erweitert. Sie steht immer vorne.  Bitte testen pb es so klappt.  Würde mich freuen.

mfg  Gast 123

Code:

Option Explicit         '3.12.2018   Mitarbeiterplan Master Versuch

Const UserPfad = "N:\1. Poolordner Aurea\1. Unternehmen\2. Kunden\2. Kundenunterlagen\04_Herongen\Personalplanung\Stundenzettel.xlsx"
'**  Hyperlink zum Stundenzettel
'B2:G32;J2:N32;R2:V32;Z2:AD32   'Kopier-Bereich



Sub Daten_inStundenzettel_kopieren_neu()
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("Stundenzettel.xlsx")

On Error Resume Next
Blatt = ThisWorkbook.Worksheets("PlanHF").[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("PlanHF")
     'Bereiche (B2:G32) nur Werte aus PlanHF kopieren
     '** Range mit Punkt davor bezieht sich auf die With Klammer!!
     .Range("B2:F32").Copy   'Quelltabelle kopieren
     StZett.Range("A2").PasteSpecial Paste:=xlValues
     StZett.Range("A2").PasteSpecial Paste:=xlPasteFormats
     'nur Werte in Zieltabelle einfügen = xlPasteValues

     .Range("J2:N32").Copy   'Werte aus J2:N32 kopieren
     StZett.Range("F2").PasteSpecial xlPasteValues
     StZett.Range("F2").PasteSpecial Paste:=xlPasteFormats
     
     .Range("R2:V32").Copy   'Werte aus R2:Y32 kopieren
     StZett.Range("K2").PasteSpecial xlPasteValues
     StZett.Range("K2").PasteSpecial Paste:=xlPasteFormats
     
     .Range("Z2:AD32").Copy   'Werte aus Z2:AD32 kopieren
     StZett.Range("P2").PasteSpecial xlPasteValues
     StZett.Range("P2").PasteSpecial Paste:=xlPasteFormats

     'Einzelzellen B1,C1 mit Werte aus PlanHF laden
     StZett.Range("A1").Value = .Range("B1").Value
     StZett.Range("B1").Value = .Range("C1").Value

     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 = "Stundenzettel.xlsx" Then
     ThisWorkbook.Activate:  GoTo neu  'Neustart
  End If
  Application.Calculation = xlAutomatic
  MsgBox "Fehler:  Stundenzettel konnte nicht geöffnet werden!"
Exit Sub

Fehler:  'unerwartete Fehlermeldung
  Application.Calculation = xlAutomatic
  MsgBox "unerwarteter Fehler:  " & Chr(10) & Error()
End Sub

[CHASiN1994]

Hey guys,

funktioniert echt top alles. ich hätte wohl noch die bitte, dass die Schriftgröße der Mappe 16 beträgt und fett wird. Zelle C1 sollte allerdings Schriftgröße 20 haben und außerdem Fett sein.. wie bekomme ich das hin bei diesem Code

Code:

Option Explicit         '3.12.2018   Mitarbeiterplan Master Versuch

Const UserPfad = "N:\1. Poolordner Aurea\1. Unternehmen\2. Kunden\2. Kundenunterlagen\04_Herongen\Personalplanung\Aushang_BF.xlsx"
'**  Hyperlink zum Stundenzettel
'B2:G32;J2:N32;R2:V32;Z2:AD32   'Kopier-Bereich



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_BF.xlsx")

On Error Resume Next
Blatt = ThisWorkbook.Worksheets("PlanBF").[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("PlanBF")
    'Bereiche (B2:G32) nur Werte aus PlanHF kopieren
    '** Range mit Punkt davor bezieht sich auf die With Klammer!!
    .Range("C2:C41").Copy   'Quelltabelle kopieren
    StZett.Range("A2").PasteSpecial Paste:=xlValues
    StZett.Range("A2").PasteSpecial Paste:=xlPasteFormats
    'nur Werte in Zieltabelle einfügen = xlPasteValues

    .Range("G2:G41").Copy   'Werte aus J2:N32 kopieren
    StZett.Range("B2").PasteSpecial xlPasteValues
    StZett.Range("B2").PasteSpecial Paste:=xlPasteFormats
   
    .Range("K2:K41").Copy   'Werte aus R2:Y32 kopieren
    StZett.Range("C2").PasteSpecial xlPasteValues
    StZett.Range("C2").PasteSpecial Paste:=xlPasteFormats
   
    .Range("O2:O41").Copy   'Werte aus Z2:AD32 kopieren
    StZett.Range("D2").PasteSpecial xlPasteValues
    StZett.Range("D2").PasteSpecial Paste:=xlPasteFormats
   
     .Range("S2:S41").Copy   'Werte aus Z2:AD32 kopieren
    StZett.Range("E2").PasteSpecial xlPasteValues
    StZett.Range("E2").PasteSpecial Paste:=xlPasteFormats
   
     .Range("W2:W41").Copy   'Werte aus Z2:AD32 kopieren
    StZett.Range("F2").PasteSpecial xlPasteValues
    StZett.Range("F2").PasteSpecial Paste:=xlPasteFormats
   
     .Range("AA2:AA41").Copy   'Werte aus Z2:AD32 kopieren
    StZett.Range("G2").PasteSpecial xlPasteValues
    StZett.Range("G2").PasteSpecial Paste:=xlPasteFormats

    'Einzelzellen B1,C1 mit Werte aus PlanHF laden
    StZett.Range("A1").Value = .Range("B1").Value
    StZett.Range("B1").Value = .Range("C1").Value

    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_BF.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 Sub

[Gast 123]

Hallo

freut mich das mein Makro ankam und gut klappt.  Hier ganz allgemein zum selbst einfügen einige Codes.  Der Punkt vor Range, Cells oder Column bezieht sich auf obige With Klammer, das Sheet "Plan HF"!  Sonst muss man den Tabellen Namen davorsetzen!!  Das kann man leicht selbst einfügen. 

Range mit Zelle oder Bereich gilt für diese Zellen.  Cells ohne () bezieht sich auf das ganze Blatt, für alle Zellen.  Man kann auch Spalten oder Zeilen markieren, über den Zusatz  .Font.Size = 14 oder Font.Bold = False/True für Fettschrift Ein- Ausschalten.  Mehr ist das nicht, ziemlich einfach.  

Am einfachsten im bestehenden Makro vor Wb,Save einfügen, und dann mit abspeichern.  Einfach mal testen bis es klappt.
Ein frohes Weihnachtsfest und ein glückliches Neues Jahr ....

mfg  Gast 123

Code:

  '** mit Punkt bezieht sich auf Worksheet("Plan HF")
  '** sonst noch das Worksheet davorsetzen
  .Cells.Font.Size = 16            'gamze Blatt Schift 16
  .Cells.Font.Bold = True          'gamze Blatt Fettschift
  .Range("C1").Font.Size = 20      'Schriftgrösse

  .Columns("xx").Font.Size = 14       'ganze Spalte auf 14
  .Columns("10:20").Font.Size = 14    'Zeilen 10-20 auf 14

  Worksgeets("Fantasie").Range("C1").Font.Size = 20

[CHASiN1994]

klar funktioniert dein Code :D

aber für das Worksheets PlanHF. Ich bräuchte allerdings diesen Code explizit für das Workbook Stundenzettel_HF und für das Worksheets, dass neu erstellt wurde. 

also genau dieser Code mit den Zellen und Spaltengröße und Schriftgröße brauche ich NUR für WB = Stundenzettel_HF. sollte ich dann nicht einfach ein neues Makro für dieses WB erstellen? oder kann ich das von PlanHF mit in das Makro integrieren weil das funktioniert dann nur auf die PlanHF.

Anschließend bleibt noch ein Ding. Ich habe eine bedingte Formatierung auf den Zellen in PlanHF. Diese Färbung wird nicht mit Pastexl.Formats.. übertragen. gibt es da eine Möglichkeit?

Beste Grüße

[schauan]

Hallöchen,

da steht doch irgendwo im Code

With ThisWorkbook.Worksheets("PlanBF")

zu Deutsch

Mit DieserDatei.Tabelle("PlanBF")

da könnte die Lösung sicher in die Richtung gehen, statt "PlanBF" den gewünschten Blattnamen einzusetzen

Wenn der Code nicht in DieserDatei wirken soll, kann man auch Datei("EineAndere") nehmen - in dem Fall Workbooks("Stundenzettel.xlsx")