Zeilen mit bestimmten Datum kopieren

[atilla]

Hallo Fennek,

Du brauchst das Format der Daten nicht ändern, wenn Du den Spezialfilter einsetzt.

Um nach einem Monat zu sortieren kannst Du im Kriterienbereich  eine Formel einsetzen.
Die Formelzelle darf keine Überschriftszelle haben und der Bezug muss sich auf den ersten Datensatz der Datenquelle beziehen.
Das Ergebnis der Formel muss einen booleschen Wert (WAHR/FALSCH) haben

z.B im folgenden wäre der Kriterienbereich B1:B2

Arbeitsblatt mit dem Namen 'Tabelle3'
	B
1
2	WAHR

Zelle	Formel
B2	=MONAT(Tabelle1!A2)=1

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

Und die erste Zelle der Daten wäre Tabelle1A2

[Fennek]

Hallo Atilla,

vielen Dank für den Hinweis, sieht sehr gut aus, auch wenn ich noch ein paar Versuche brauche, um es umzusetzen.

Mfg

[stonemaus]

Hallo zusammen,


mein Code von gestern gehört in die Tonne.

Hier ein funktionierender Code:

Code:

Option Explicit

Sub vMonate_kopieren()
 Dim lngZ As Long, i As Long, j As Long, k As Long, m As Long, n As Long
 Dim vMonat As Variant
 Dim vntQ As Variant
 Dim arrDaten()
 Dim oDic As Object
 Set oDic = CreateObject("scripting.dictionary")
Dim varKey
 Do
 vMonat = Application.InputBox(prompt:="Bitte den vMonat eingeben.", Title:="Nur Zahlen eingeben", Default:="", Type:=1)
 If VarType(vMonat) = vbBoolean Then Exit Sub
   If vMonat >= 1 And vMonat <= 12 Then
     Exit Do
   End If
   MsgBox "Fehler! Nur Zahlen zwischen 1 und 12!", 16, "Hinweis"
 Loop
 
 With Sheets("Tabelle1")
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
   vntQ = .Range("A2:D" & lngZ)
 End With
 
 For i = 1 To lngZ - 1
   If Month(vntQ(i, 1)) = vMonat Then
   oDic(vntQ(i, 1)) = oDic(vntQ(i, 1)) & "#" & i
   End If
 Next i
 
 If oDic.Count Then
   For Each varKey In oDic
     For i = 1 To UBound(Split(oDic(varKey), "#"))
       ReDim Preserve arrDaten(oDic.Count * 4, m)
       arrDaten(k, n) = varKey
       arrDaten(k + 1, n) = vntQ(Split(oDic(varKey), "#")(i), 2)
       arrDaten(k + 2, n) = vntQ(Split(oDic(varKey), "#")(i), 4)
       n = n + 1
       m = Application.Max(m, n)
     Next i
     n = 0
     k = k + 4
   Next
   With Sheets("Tabelle2")
     .Cells.ClearContents
     .Cells(2, 1).Resize(m, oDic.Count * 4) = Application.Transpose(arrDaten)
   End With
 Else
   MsgBox "Keine Daten für gesuchten Monat!"
 End If
 
End Sub

@Andre,
ich verstehe die Aufgabe so wie Ralf es beschrieben hat, es sollen Tage eines Monats im Block neben aneinander mit einer Leerspalte zwischen den einzelnen Tagesblöcken dargestellt werden.

Hallo atilla

Vielen Dank erst mal, ich habe mit dieser Vorlage meine Probleme bestens behoben.
Es waren nur einige Anpassungen nötig. Bitte verzeih mir meine Rechtschreibung ich weiß das ich darin nicht sehr gut bin.

Also nochmal besten Dank
Gruß Peter

[stonemaus]

Hallo clever-Excel-forum Leute
 
Ich mochte mich für alle die mit in diesem Beitrag geholfen habe herzlichst bedanken.
Ich möchte mich dafür entschuldigen wenn ich nicht Jeden einzeln geantwortet habe.
 
Ich bin sehr froh das es solche hervorragende Hilfe im Web gibt
 
MfG Peter

:18:

[Rabe]

Hi,

Hier ein funktionierender Code:

diese Lösung gefällt mir!

[Fennek]

Hallo,

schön, dass dem Fragesteller geholfen wurde, dann kann ich noch einen Experimentalcode nachschieben ohne Verwirrung auszulösen.

Der Code nutzt die - für mich neue - Array Funktion 'Filter', die ich aber eher unbeholfen ausprobiert habe.

Code:

Sub sFilter()
'label in a1, sonst Datumswerte in Spalte A
Dim rng as range
Dim ar, arF
iMon = 4
iCol = "A"
ar = application.transpose(columns(iCol).specialcells(xlconstants))
For i = 2 to ubound(ar)
ar(i) = i & ", " & format(cdate(ar(i), "yyyy-m")
Next
arF = filter(ar, "-"& iMon, true, vbBinaryCompare)
Set rng = cells(1, iCol)
For i = lbound(arF) to unbound(arF)

Set rng = union(rng, cells(split(arF(i), ",")(0), iCol))
Next
Set rng = union(rng, rng.offset(0,1), rng.offset(0,3))
Sheets(2).clear
Rng.copy sheets(2).range("a1")
End sub

[atilla]

Hallo Ralf,

schön, dass es gefällt.

Ich selbst würde es aber ohne Inputbox machen.
Bei dieser Variante muss der Code erst manuell oder per Schaltfläche gestartet werden. Dann muss noch die Inputbox-Eingabe bestätigt werden.

Ich würde in Tabelle2, der Ergebnistabelle eine Zelle als Eingabezelle nutzen und den Code über das Change Ereignis automatisch starten lassen.

Ich habe es mal in der angehängten Datei realisiert.

Eingabezelle ist die Zelle A1 in Tabelle2.
Nach der Eingabe stehen die Ergebnisse in der selbigen Tabelle.
Wenn die Eingabe mit Enter abgeschlossen wird, wird wieder die Eingabezelle ausgewählt.
Man kann dann ohne die Zelle noch mal mit der Maus ansteuern zu müssen eine neue Eingabe machen.


  Tage eines Monats kopieren(ati).xlsm (Größe: 22,55 KB / Downloads: 7)

[Rabe]

Hi Atilla,

Ich selbst würde es aber ohne Inputbox machen.

das ist noch besser!

[schauan]

Hallöchen,

hier mal noch meine Variante, auf ati's Datei angepasst. Zusatzeingabe: Jahr, vierstellig, in B1.
Der Code kopiert die Daten einschl. Überschriften. Soll's ohne sein, dann in den beiden Kopierzeilen aus A1 bzw. D1 A2 bzw. D2 machen.
Eingefügt wird ab Zeile 10, zum Vergleich mit den anderen codes. Produktiv dann Einfügezeile weiter hoch setzen.

Sollte das Jahr mal eine Rolle spielen - Daten z.B. weiter rechts eingefügt werden, müsste man das noch codieren. Zur Ausführung des codes den Aufruf im Makro Worksheet_Change ändern

Modul Modul3

Sub Filtern() 
'Mit dem Blatt Tabelle1 - beachte Punktsetzung vor Bereichen! 
With Sheets("Tabelle1") 
  'Autofilter setzen 
  .Range("A1").AutoFilter 
  .Columns(1).AutoFilter Field:=1, Operator:= _
      xlFilterValues, Criteria2:=Array(1, Cells(1, 1).Value & "/" & Day(DateSerial(Cells(1, 2).Value, _
         Cells(1, 1).Value + 1, 0)) & "/" & Cells(1, 2).Value) 
  'Gefilterte Zellen kopieren 'und am Zielort einfuegen. Spaltenoffset monatsabhaengig jeweils 3 Spalten versetzt. 
  .Range("A1:B" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy Range("A10").Offset(0, (Cells(1, 1).Value - 1) * 4) 
  'Gefilterte Zellen kopieren 'und am Zielort einfuegen. Spaltenoffset monatsabhaengig jeweils 3 Spalten versetzt. 
  .Range("D1:D" & .Cells(Rows.Count, 1).End(xlUp).Row).Copy Range("A10").Offset(0, 2 + (Cells(1, 1).Value - 1) * 4) 
  'Autofilter zurueck setzen 
  .Range("A1").AutoFilter 
'Ende Mit dem Blatt Tabelle1 
End With 
'Kopiermarkierung aus 
Application.CutCopyMode = False 
End Sub 
 

[atilla]

Hallo Andre,

nach meinem Verständnis der Aufgabe erhält man mit Deinem Code nicht das gewünschte Ergebnis von Peter.

Die Darstellung soll so wie in meinem ersten Beitrag sein.
Du müsstest nach dem Filtern des Monats noch in einer Schleife die Tage aus dem Monat herausfiltern.

Wenn Du meinen Code testest, dann erkennst Du, wie das Ergebnis Dargestellt werden soll.
Die Idee mit dem Jahr ist gut, sollte ich bei mir auch mit einbauen.


Und hier noch für Alle, die eine Datei mit Makros nicht runterladen aber gerne das Ergebnis nachbauen wollen, der Code und die Tabellen.

Quelltabelle mit Daten heißt "Tabelle1" und ist so aufgebaut:
(alle Tabellen verkürzt dargestellt)

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C	D
1	datum	wertB		wertd
2	01.01.2016	wertB2		wertd2
3	02.01.2016	wertB3		wertd3

Diese Tabelle wurde mit Tab2Html (v2.4.1) erstellt. ©Gerd alias Bamberg

Die Zieltabelle heißt "Tabelle2" und Zelle A1 ist für die Eingabe einer Monatszahl reserviert.
Ich habe dann noch eine Liste mit den Monatszahlen erstellt und diese Liste im Namensmanager als "monate" benannt.
Diese Liste dient als Datengültigkeitsliste für die Zelle A1, so können Falscheingaben leicht abgefangen werden.

Das sind die Vorgaben für die Tabellen gewesen.

Dieser Code kommt hinter die Zieltabelle "Tabelle2"

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
 If Target.Address(0, 0) = "A1" Then
   On Error GoTo fehler
   Application.EnableEvents = False
   Target.Select
   vMonate_kopieren
 End If
fehler:
 Application.EnableEvents = True
 If Err Then MsgBox "Fehler: " & vbLf & vbLf & Err.Description _
   & vbLf & vbLf & "Ein unerwarteter Fehler ist aufgetreten!" & vbLf & "Bitte überprüfen sie Ihre Eingabe."
End Sub

Folgender kann in ein Modul kopiert werden:

Code:

Sub Tage_eines_Monate_kopieren()
 Dim lngZ As Long, i As Long, j As Long, k As Long, m As Long, n As Long
 Dim vMonat As Variant
 Dim vntQ As Variant
 Dim arrDaten()
 Dim oDic As Object
 Set oDic = CreateObject("scripting.dictionary")
 Dim varKey

 With Sheets("Tabelle2")
   Sheets("Tabelle2").Cells(3, 1).Resize(.Rows.Count - 3, .Columns.Count).ClearContents
 End With
 vMonat = Cells(1, 1)
 With Sheets("Tabelle1")
   lngZ = .Cells(.Rows.Count, 1).End(xlUp).Row
   vntQ = .Range("A2:D" & lngZ)
 End With
 
 For i = 1 To lngZ - 1
   If Month(vntQ(i, 1)) = vMonat Then
   oDic(vntQ(i, 1)) = oDic(vntQ(i, 1)) & "#" & i
   End If
 Next i
 
 If oDic.Count Then
   For Each varKey In oDic
     For i = 1 To UBound(Split(oDic(varKey), "#"))
       ReDim Preserve arrDaten(oDic.Count * 4, m)
       arrDaten(k, n) = varKey
       arrDaten(k + 1, n) = vntQ(Split(oDic(varKey), "#")(i), 2)
       arrDaten(k + 2, n) = vntQ(Split(oDic(varKey), "#")(i), 4)
       n = n + 1
       m = Application.Max(m, n)
     Next i
     n = 0
     k = k + 4
   Next
   Sheets("Tabelle2").Cells(3, 1).Resize(m, oDic.Count * 4) = Application.Transpose(arrDaten)

 Else
   Sheets("Tabelle2").Cells(3, 1) = "Keine Daten für gesuchten Monat!"
 End If
 
End Sub