Monat auswählen und kopieren

Question

Hallo,
ich suche eine Lösung mit VBA. In meiner Tabelle steht in Spalte B ab B6 fortlaufend das Datum im Format JJJJ-MM-TT. Es soll mit einer Abfrage der Monat ausgewählt werden und dann alle Tage des Monats mit den zugehörigen Werten in C:Q markiert werden und in ein bestehendes Tabellenblatt mit dem Namen MMJJ nach B6:Q37 kopiert werden.
Vielleicht kann mir jemand auch teilweise helfen.
Mfg
Tom3

Answer 1

Hallo Tom,

benutze doch Autofilter und kopiere nur die sichtbaren Zellen.

Gruß Hajo

Answer 2

Hallo Hajo,
ich wollte aber eine VBA Lösung, da mehrere Mitarbeiter damit arbeiten, denen Excel nicht so geläufig ist. Trotzdem vielen Dank.
Freundliche Grüße
Tom3

Answer 3

Hallo Tom,

eine VBA-Lösung kannst Du selbst erzeugen, indem Du Hajo's Vorschlag mit dem Makrorecorder aufzeichnest und den entstandenen Code einem Button oder einer Tastenkombination zuweist.

Gruß
Rainer

Answer 4

Hallo Tom,

ein Vorschlag:

Sub Datum_und_Werte_C_Q_kopieren()
Dim bis As Integer, m As String, monat As Date, von As Integer, z As Integer

m = InputBox("Eingabe von Monat und Jahr " & vbCrLf & "in der Form 01.2009 | Januar 2009 | Jan 2009", _
"Eingabe des Monats", CStr(Month(Date)) & "." & CStr(Year(Date)))
monat = DateValue("01." & m)
' Von welcher Zeile bis zu welcher Zeile kopieren?
von = 0
bis = 0
For z = 6 To ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row
If ThisWorkbook.Worksheets("Tabelle1").Cells(z, 2).Value >= monat Then
von = z
monat = DateAdd("m", 1, monat)
Do
z = z + 1
Loop Until ThisWorkbook.Worksheets("Tabelle1").Cells(z, 2).Value >= monat
bis = z - 1
Exit For
End If
Next z
' Daten B[von]:Q[bis] in Tabelle "MMJJ" kopieren
If (5 < von) And (von < bis) Then
If ThisWorkbook.Worksheets("MMJJ").Cells(1, 2).Value = "" Then
z = 0
Else
z = ThisWorkbook.Worksheets("MMJJ").Cells(Rows.Count, 2).End(xlUp).Row
End If
ThisWorkbook.Worksheets("Tabelle1").Range("B" & CStr(von) & ":Q" & CStr(bis)).Copy
' eine Leerzeile Zwischenraum lassen
ThisWorkbook.Worksheets("MMJJ").Range("B" & CStr(z + 2)).PasteSpecial Paste:=xlValues, Operation:=xlNone
' direkt unter vorhandene Daten ohne Zwischenraum kopieren
'ThisWorkbook.Worksheets("MMJJ").Range("B" & CStr(z + 1)).PasteSpecial Paste:=xlValues, Operation:=xlNone
Application.CutCopyMode = False
'ThisWorkbook.Worksheets("MMJJ").Select
'ThisWorkbook.Worksheets("MMJJ").Range("A1").Activate
'ThisWorkbook.Worksheets("Tabelle1").Select
ThisWorkbook.Worksheets("Tabelle1").Range("A1").Activate
Else
MsgBox "Kein Zeitbereich gefunden, es wird nichts kopiert."
End If
End Sub

MfG Charlotte

Answer 5

Hallo Charlotte,
Entschuldigung, dass ich erst jetzt dazu komme dein Makro zu testen.

If ThisWorkbook.Worksheets("MMJJ").Cells(1, 2).Value = "" Then

Leider bringt das Makro an dieser Stelle einen Fehler ( Index außerhalb des gültigen Bereiches, Laufzeitfehler 9 ). Mir fehlt leider das Wissen herauszufinden, woran das liegen könnte. Kannst Du bzw. jemand mir helfen ? Vielen Dank.
Mfg Tom

Answer 6

Hallo Tom,

das sieht ganz stark danach aus, dass Dein Tabellenblatt, in das die Werte kopiert werden sollen, nicht "MMJJ" heißt, sondern vielleicht "1209" oder so. Allerdings sollte

"... in ein bestehendes Tabellenblatt mit dem Namen MMJJ nach B6:Q37 kopiert werden."

Überprüfe bei dieser Gelegenheit auch gleich, ob das erste Tabellenblatt, aus dem die Werte kopiert werden sollen, auch tatsächlich "Tabelle1" heißt. Groß-/ Kleinschreibung spielt dabei keine Rolle. Die Tabellenblatt-Namen unten auf den "Reitern" und im VBA-Code müssen übereinstimmen. Am einfachsten kriegst Du das hin, wenn Du im VBA-Editor (mit ALT+F11 öffnen, dann den VBA-Code des Makros anzeigen) die Suchen-und-Ersetzen-Funktion (STRG+H) benutzt und bei

Suchen in:
(*) in der aktuellen Prozedur
[Alle ersetzen]

lässt:

"Tabelle1" --> "Tabellenblatt-Name_der_Quelle"
"MMJJ" --> "" "Tabellenblatt-Name_des_Ziels"

Da ich Deine konkreten Namen nicht weiß und auch nicht, wie variabel (mit zusätzlichen Abfragen?) das Kopieren stattfinden soll, kann ich Dir erstmal nicht weiter helfen. Aber ansonsten sollte der Code laufen, ich habe ihn getestet.

MfG Charlotte

Answer 7

Hallo Charlotte,
ja das stimmt, ich habe mich wohl nicht richtig ausgedrückt. Ich meinte, das die Tabellenblätter mit Monat und Jahr benannt sind, also 1009, 1109 usw.
Hier ist meine Beispieltabelle:
http://www.file-upload.net/download-2064993/Mappe1.xls.html
Es sollen nachdem der entsprechende Monat eingegeben ist, die Werte des Monats in die dazugehörigen Tabellenblätter kopiert werden.
Mit freundlichen Grüßen
Tom

Answer 8

Sorry,

keine Zeit.

www.file-upload.net/download-2065060/SN2287203.xls.html

MfG Charlotte

Answer 9

Hallo Tom,

ich habe den Code an die 3 Ziel-Tabellen "1009", "1109", "1209" angepasst, getestet und in Deine Datei kopiert.

Sub Datum_und_Werte_C_Q_kopieren()
Dim bisZ As Integer, m As String, monat As Date, nachZ As Integer, vonZ As Integer, z As Integer
Dim nachTbl As String

m = InputBox("Eingabe von Monat und Jahr " & vbCrLf & "in der Form 01.2009 | Januar 2009 | Jan 2009", _
"Eingabe des Monats", CStr(Month(Date)) & "." & CStr(Year(Date)))
monat = DateValue("01." & m)
' In welche Tabelle "MMJJ" kopieren?
nachTbl = CStr(Month(monat)) & Right(CStr(Year(monat)), 2)
' von welcher Zeile bis zu welcher Zeile kopieren?
vonZ = 0
bisZ = ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row
For z = 6 To ThisWorkbook.Worksheets("Tabelle1").Cells(Rows.Count, 2).End(xlUp).Row
If ThisWorkbook.Worksheets("Tabelle1").Cells(z, 2).Value >= monat Then
vonZ = z
monat = DateAdd("m", 1, monat)
Do
z = z + 1
Loop Until ThisWorkbook.Worksheets("Tabelle1").Cells(z, 2).Value >= monat Or z > bisZ
bisZ = z - 1
Exit For
End If
Next z

' Daten B[vonZ]:Q[bisZ] in Tabelle "MMJJ" kopieren
If (5 < vonZ) And (vonZ < bisZ) Then
z = ThisWorkbook.Worksheets(nachTbl).Cells(Rows.Count, 2).End(xlUp).Row
If z = 1 And ThisWorkbook.Worksheets(nachTbl).Cells(1, 2).Value = "" Then z = 0
ThisWorkbook.Worksheets("Tabelle1").Range("B" & CStr(vonZ) & ":Q" & CStr(bisZ)).Copy
' eine Leerzeile Zwischenraum lassen
ThisWorkbook.Worksheets(nachTbl).Range("B" & CStr(z + 2)).PasteSpecial Paste:=xlValues, Operation:=xlNone
' direkt unter vorhandene Daten ohne Zwischenraum kopieren
'ThisWorkbook.Worksheets(nachTbl).Range("B" & CStr(z + 1)).PasteSpecial Paste:=xlValues, Operation:=xlNone
Application.CutCopyMode = False
ThisWorkbook.Worksheets(nachTbl).Select
ThisWorkbook.Worksheets(nachTbl).Range("A1").Activate
ThisWorkbook.Worksheets("Tabelle1").Select
ThisWorkbook.Worksheets("Tabelle1").Range("A1").Activate
Else
MsgBox "Kein Zeitbereich gefunden, es wird nichts kopiert."
End If
End Sub

Download-Link: www.file-upload.net/download-2067566/SN2287203.xls.html

Es gibt im Code noch eine Wahlmöglichkeit, und zwar, ob oberhalb und - falls mehrmals in ein Tabellenblatt kopiert wird - zwischen den Blöcken eine Leerzeile gelassen wird oder nicht. Was besser ist, hängt sicherlich auch davon ab, was Du insgesamt vorhast und ob Du den Code noch weiterentwickelst. Momentan wird eine Leerzeile gelassen. Um dies zu ändern, müsstest Du
ein Kommentarzeichen ' oder REM vor
ThisWorkbook.Worksheets(nachTbl).Range("B" & CStr(z + 2)).PasteSpecial Paste:=xlValues, Operation:=xlNone
setzen und und das Kommentarzeichen ' vor
'ThisWorkbook.Worksheets(nachTbl).Range("B" & CStr(z + 1)).PasteSpecial Paste:=xlValues, Operation:=xlNone
löschen.

MfG Charlotte

Answer 10

Hallo Charlotte,
habe deinen Code gleich getestet und bin beeindruckt. Genau so habe ich es mir vorgestellt. Vielen Dank für Deine Hilfe und ein schönes Weihnachtsfest.
Freundliche Grüße
Tom