VBA Hilfe--Wie kann ich Datum abhängige Daten untereinander auflisten ?

Question

Folgenden Code habe ich versucht für meine Bedürfnisse anzupassen, aber da ich keine Ahnung von der Materie habe, ist es nur beim Kopieren des Codes geblieben. Der untere braucht 12 Arbeitsblätter nach 12 Monaten. Der Code schreibt die Daten nach einem horizontalen Kalender. Mein Kalender ist untereinander reihende 365 Tage. Das Datum wird im Arbeitsblatt "Schicht 1" bei B6 eingegeben. Dabei sollten folgende Zellen des Arbeitsblatts "Schicht 1"; Zelle W3; Zelle W4, Zelle W5; Zelle W6; Zelle W7; Zelle M3; Zelle M4; Zelle M5; Zelle M6; Zelle M7 kopiert werden.

Sub Daten_in_Tabelle_Schicht_kopieren_Klicken()
    Dim wksTab As Worksheet
    Dim intSpalte As Integer
    Set wksTab = Worksheets(Format(Range("B6"), "mmm"))
    With wksTab
        For intSpalte = 6 To 36
            If .Cells(4, intSpalte) = Range("B6") Then
                .Cells(8, intSpalte) = Range("W3")
                .Cells(9, intSpalte) = Range("W4")
                .Cells(10, intSpalte) = Range("W5")
                .Cells(11, intSpalte) = Range("W6")
                .Cells(17, intSpalte) = Range("I37")
                .Cells(22, intSpalte) = Range("S17")
                .Cells(23, intSpalte) = Range("S19")
                .Cells(23, intSpalte) = Range("S20")
                .Cells(29, intSpalte) = Range("S35")
                .Cells(31, intSpalte) = Range("S37")
                .Cells(35, intSpalte) = Range("A1") '<==????? Zelladresse anpassen
                .Cells(36, intSpalte) = Range("A1") '<==????? Zelladresse anpassen
                Exit For
            End If
        Next intSpalte
    End With
End Sub

https://supportnet.de/forum/?qa=blob&qa_blobid=13267284043232647019

Answer 1

https://supportnet.de/forum/?qa=blob&qa_blobid=10969706756749237747

Das ist die Datei.

Answer 2

Hallo,

keine Ahnung ob ich dich richtig verstanden habe.

Schau mal, ob der folgende Code so für dich passt:

Sub schicht()
Dim wksQuelle As Worksheet
Dim dDatum As Date
Dim lngZeile As Long
Dim Ergebnis

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Name des Quellarbeitsblattes in Variable schreiben
Set wksQuelle = ActiveSheet

'Datum einlesen
dDatum = wksQuelle.Range("B6")

'Datum suchen
With Worksheets("2023")
 With .Range("A:A")
    Set Ergebnis = .Find(dDatum, LookIn:=xlValues, lookat:=xlPart)
 End With

 If Ergebnis Is Nothing Then
    'Meldung ausgeben, falls Datum nicht gefunden wurden
    MsgBox "Das Datum " & dDatum & " wurde leider nicht gefunden! Abbruch", 0, "Suche abgeschlossen"
    Exit Sub
   Else
    'Zeile von gefundenem Datum in Variable schreiben
    lngZeile = Ergebnis.Row
  End If
 
  'Daten ins Jahres-Arbeitsblatt übertragen
  .Cells(lngZeile, 2) = wksQuelle.Range("W3")
  .Cells(lngZeile, 3) = wksQuelle.Range("W4")
  .Cells(lngZeile, 4) = wksQuelle.Range("W5")
  .Cells(lngZeile, 5) = wksQuelle.Range("W6")
  .Cells(lngZeile, 6).FormulaLocal = "=Summe(" & .Cells(lngZeile, 2).Address & ":" & .Cells(lngZeile, 5).Address & ")"
  .Cells(lngZeile, 7) = wksQuelle.Range("M3")
  .Cells(lngZeile, 8) = wksQuelle.Range("M4")
  .Cells(lngZeile, 9) = wksQuelle.Range("M5")
  .Cells(lngZeile, 10) = wksQuelle.Range("M6")
  .Cells(lngZeile, 11).FormulaLocal = "=Summe(" & .Cells(lngZeile, 7).Address & ":" & .Cells(lngZeile, 10).Address & ")"

  'auf Tabellenblatt wechseln
  .Activate

End With

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 3

Cool , das ist es .Besten Dank...

Answer 4

Guten Morgen,

kann man vielleicht mit einer Messagebox darauf hinweisen, dass man gerade die Zelleninhalte des Datums überschreibt.

Also, wenn zu dem Datum bereits in der betreffenden Zelle Werte vorhanden sind, soll der Anwender entscheiden, ob er ihn doch überschreiben möchte, oder nicht.

Ich habe es mit dem folgenden Code versucht, aber wahrscheinlich waren meine Variablen falsch, oder ich habe ihn falsch platziert. Ich habe ihn nach dem Code platziert.  'Zeile von gefundenem Datum in Variable schreiben
    lngZeile = Ergebnis.Row
  End If

Mein Versuch Code:

 If IsEmpty(.Value) Then
         .Value = Ergebnis
      ElseIf MsgBox("Ein Wert ist schon vorhanden. Überschreiben?", vbYesNo) = vbYes Then
         .Value = Ergebnis
      End If

Ich würde mich über eine Ergänzung sehr freuen. danke..

Answer 5

Hallo,

hier das Makro mit Ergänzung:

Sub schicht()
Dim wksQuelle As Worksheet
Dim dDatum As Date
Dim lngZeile As Long
Dim Ergebnis
Dim Antwort

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Name des Quellarbeitsblattes in Variable schreiben
Set wksQuelle = ActiveSheet

'Datum einlesen
dDatum = wksQuelle.Range("B6")

'Datum suchen
With Worksheets("2023")
 With .Range("A:A")
    Set Ergebnis = .Find(dDatum, LookIn:=xlValues, lookat:=xlPart)
 End With

 If Ergebnis Is Nothing Then
    'Meldung ausgeben, falls Datum nicht gefunden wurden
    MsgBox "Das Datum " & dDatum & " wurde leider nicht gefunden! Abbruch", 0, "Suche abgeschlossen"
    Exit Sub
   Else
    'Zeile von gefundenem Datum in Variable schreiben
    lngZeile = Ergebnis.Row
  End If
  
  'Prüfen, ob in dem Einfügebereich bereits etwas steht - mit ANZAHL2
  If Application.CountA(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, 11))) > 0 Then
    'Nachfrage, ob vorhandene Daten überschrieben werden sollen
    Antwort = MsgBox("Bei dem Datum " & dDatum & " sind bereits Daten vorhanden. Sollen diese überschrieben werden?", 36, "Bereits Daten vorhanden")
    'Bei Nein als Anwort, Makro beenden
    If Antwort = vbNo Then Exit Sub
   End If
  
  'Daten ins Jahres-Arbeitsblatt übertragen
  .Cells(lngZeile, 2) = wksQuelle.Range("W3")
  .Cells(lngZeile, 3) = wksQuelle.Range("W4")
  .Cells(lngZeile, 4) = wksQuelle.Range("W5")
  .Cells(lngZeile, 5) = wksQuelle.Range("W6")
  .Cells(lngZeile, 6).FormulaLocal = "=Summe(" & .Cells(lngZeile, 2).Address & ":" & .Cells(lngZeile, 5).Address & ")"
  .Cells(lngZeile, 7) = wksQuelle.Range("M3")
  .Cells(lngZeile, 8) = wksQuelle.Range("M4")
  .Cells(lngZeile, 9) = wksQuelle.Range("M5")
  .Cells(lngZeile, 10) = wksQuelle.Range("M6")
  .Cells(lngZeile, 11).FormulaLocal = "=Summe(" & .Cells(lngZeile, 7).Address & ":" & .Cells(lngZeile, 10).Address & ")"

  'auf Tabellenblatt wechseln
  .Activate

End With

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

End Sub

Gruß

M.O.

Answer 6

Vielen vielen Dank

Answer 7

Guten Tag,

ich habe nicht weitergedacht. 

Meine Datei soll als Vorlage dienen. Der Schichtführer möchte jeden Tag in der Frühschicht für den neuen Arbeitstag mit aktuellem Datum eine Datei erstellen. 

Deshalb ist meine Idee mit dem Arbeitsblatt "2023" in der gleichen Datei falsch. Ich brauche eine zusätzliche Datei mit dem Titel "2023" mit dem Arbeitsblattname "2023". Ich habe diese Hürde lösen können, nicht unbedingt professionell. Dafür habe ich folgende Ergänzungen gemacht (die Fettschriften): 

Sub schicht()
Dim wksQuelle As Worksheet
Dim dDatum As Date
Dim lngZeile As Long
Dim Ergebnis
Dim Antwort
Dim y As Workbook

'Bildschirmaktualisierung ausschalten:
Application.ScreenUpdating = False

'Name des Quellarbeitsblattes in Variable schreiben
Set wksQuelle = ActiveSheet

'Datum einlesen
dDatum = wksQuelle.Range("B6")

'Öffne die Datei "2023"

Set y = Workbooks.Open("C:\Users\Zagor\Desktop\2023.xlsx")

'Datum suchen
With Worksheets("2023")
 With .Range("A:A")
    Set Ergebnis = .Find(dDatum, LookIn:=xlValues, lookat:=xlPart)
 End With

 If Ergebnis Is Nothing Then
    'Meldung ausgeben, falls Datum nicht gefunden wurden
    MsgBox "Das Datum " & dDatum & " wurde leider nicht gefunden! Abbruch", 0, "Suche abgeschlossen"
    Exit Sub
   Else
    'Zeile von gefundenem Datum in Variable schreiben
    lngZeile = Ergebnis.Row
  End If
  
  'Prüfen, ob in dem Einfügebereich bereits etwas steht - mit ANZAHL2
  If Application.CountA(.Range(.Cells(lngZeile, 2), .Cells(lngZeile, 11))) > 0 Then
    'Nachfrage, ob vorhandene Daten überschrieben werden sollen
    Antwort = MsgBox("Bei dem Datum " & dDatum & " sind bereits Daten vorhanden. Sollen diese überschrieben werden?", 36, "Bereits Daten vorhanden")
    'Bei Nein als Anwort, Makro beenden
    If Antwort = vbNo Then Exit Sub

   End If
  
  'Daten ins Jahres-Arbeitsblatt übertragen
  .Cells(lngZeile, 2) = wksQuelle.Range("W3")
  .Cells(lngZeile, 3) = wksQuelle.Range("W4")
  .Cells(lngZeile, 4) = wksQuelle.Range("W5")
  .Cells(lngZeile, 5) = wksQuelle.Range("W6")
  .Cells(lngZeile, 6).FormulaLocal = "=Summe(" & .Cells(lngZeile, 2).Address & ":" & .Cells(lngZeile, 5).Address & ")"
  .Cells(lngZeile, 7) = wksQuelle.Range("M3")
  .Cells(lngZeile, 8) = wksQuelle.Range("M4")
  .Cells(lngZeile, 9) = wksQuelle.Range("M5")
  .Cells(lngZeile, 10) = wksQuelle.Range("M6")
  .Cells(lngZeile, 11).FormulaLocal = "=Summe(" & .Cells(lngZeile, 7).Address & ":" & .Cells(lngZeile, 10).Address & ")"

  'auf Tabellenblatt wechseln
  .Activate

End With

'Bildschirmaktualisierung einschalten:
Application.ScreenUpdating = True

'Speichere y:
y.Save
'Schließe y:
y.Close

End Sub

Ich brauche Hilfe bei den unteren Punkten:

1. Wenn die Zeilen überschrieben sind, und ich "Nein, bitte die Zeile nicht überschreiben " betätige, dann bleibt die Datei "2023.xlsx" offen. Ich muss sie manuell schließen.
2. Ich hätte es gern, wenn beim Schließen der nach dem aktuellen Datum erstellten-Datei die Daten in die Datei "2023.xlsx" kopiert werden könnten.

Answer 8

Aktuell verfahren die Schichtführer so:

mit dem Code wird  über eine Schaltfläche aus der Vorlage eine Datei erstellt:

Sub Speichern()

Dim Save_Date As String

Dim Path As String

Save_Date = Date

Path = "M:\040_Prod\030_Kommunikation\644\30_Schichtübergabe\"
m = "-"
n = "Fertigung"
Date_DD = Mid(Save_Date, 1, 2)
Date_MM = Mid(Save_Date, 4, 2)
Date_YYYY = Mid(Save_Date, 7, 4)
Save_Date = Date_YYYY + m + Date_MM + m + Date_DD + TN

ActiveWorkbook.SaveAs Filename:=Path + Save_Date + m + n + ".xls", FileFormat:=xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

Danach darf keiner der Schichtführer die Schaltfläche betätigen. Wenn sie diverse Themen eingeben, dann wird über das Schließen die Daten gespeichert.

Ich möchte mich im Voraus für die Unterstützung bedanken.

Answer 9

1. Wenn die Zeilen überschrieben sind, und ich "Nein, bitte die Zeile nicht überschreiben " betätige, dann bleibt die Datei "2023.xlsx" offen. Ich muss sie manuell schließen.

Den Punkt konnte ich doch lösen.

Answer 10

2. Ich hätte es gern, wenn beim Schließen der nach dem aktuellen Datum erstellten-Datei die Daten in die Datei "2023.xlsx" kopiert werden könnten.

Der zweite Punkt ist auch abgehackt.