Zeilen mit bestimmten Datum kopieren

[stonemaus]

Hallo liebe Helfer

Ich habe nachdem ich alle möglichen Foren und möglichen Vorlagen kombiniert habe es nicht geschafft mir was Funktionierendes zu konstruieren.

Ich habe in einem Tabellenblatt (owssvr) hunderte Zeilen mit Daten gefüllt.
in Spalte A2:A stehen das Datums für das aktuelle Jahr, in Spalte B2: B stehen Zahlen und in Spalte D2: D Bezeigungen.
Das heißt es gibt immer einige Zeilen gleichen Datums (z.B. 10 mal 05.02.2016)
Nun das was ich tun möchte: Ich möchte mittels VBA mit eine Inputbox ein bestimmte Monat vorgeben, danach sollte die einzelnen Tage in eine zweite Tabelle kopiert werden. Also in Tabelle2 A1 bis Cxx den 01.02.2016 in E1 bis Gxx den 02.02.2016 usw.

Vielleicht können Sie mir helfen
Vielen Dank schon mal im Voraus Peter  

[Fennek]

Hallo Peter,

da sich bis jetzt niemand für eine Antwort efunden hat, versuche ich es einmal.

Solange du nicht sehr gute Gründe für die Kopie eines Monats hast, fällt es eher in die Kategorie "sollte man besser nicht machen".

Ein 'normaler' Weg wäre, eine Pivot-Tabelle anzulegen und dann, z.b. mit einem 'Slicer' den Monat auszuwählen.

Mfg

[Käpt'n Blaubär]

Hallo Peter,

bestimmt hast Du schon mal irgendwo gelesen oder gehört, daß, wenn man was programmieren will, man exakte Vorgaben benötigt.
Übrigens, auch bei der Arbeit mit Formeln ist es nicht anders, denn sonst gibt es eher Zufallstreffer oder Fehlermeldungen.

Deine Angaben sind meiner Ansicht  nach eher im "nicht wirklich vorhanden"-Bereich angesiedelt und darum glaube ich nicht, daß
Dir, wenn Du das nicht änderst, irgendjemand helfen kann. Auch das trifft meiner Meinung nach auch bei Formellösungen zu.

Formuliere Deine Anfrage bitte neu und stelle Dir mal die folgende Situation vor:
Du weißt, was Du machen willst, .... wir nicht. Wir kennen auch nicht Dein Arbeitsblatt und schon gar nicht, was darin passieren soll,
wenn etwa dieses oder jenes Ereignis eintritt. Wie also soll da jemand was programmieren können?

Mit anderen Worten:  "mach' uns schlau damit wir helfen können!!!"

[Rabe]

So, hier mal, was ich mir zusammengereimt habe:

Er hat eine Tabelle mit Tagesdatum in Spalte A.

1. Nun will er über einen Button eine Inputbox haben, in der er einen Monat eingibt.
   
2. Dieser Monat soll dann aus der Gesamt-Datenliste herauskopiert werden in ein zweites Blatt.
   
3. Immer die Spalten A, B und D direkt nebeneinander und die Folgetage rechts davon mit jeweils einer Spalte Abstand
   (alle Daten des ersten Tags des Monats in Spalte A, B, C; zweiter Tag in Spalte E, F, G; dritter Tag in I, J, K; usw...)
   

[schauan]

Hallöchen,

im Prinzip könnte man das so lösen. Die Daten werden mit diesem Code immer ab Zeile 1 eingefügt, eventuelle Altdaten dadurch ganz oder teilweise überschrieben. Das Tagesarray müsste hinsichtlich des Februar noch flexibel angepasst werden.

Code:

Sub Filtern()
'Variablendeklarationen
'Integer, Variant-Array
Dim iMon%, arrDays
arrDays = Array(31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
'Monatseingabe der Variable iMon zuweisen
iMon = InputBox("Bitte Monat eingeben: ", "Monatsauswahl", 1)
'Fehlerausgabe bei ungueltigem Monatswert.
'Hinweis: Kommazahlen werden in Ganzzahlen gewandelt!
If iMon < 1 Or iMon > 12 Then MsgBox "Kein Gültiger Monat!": Exit Sub
'Autofilter setzen
Range("A1").AutoFilter
ActiveSheet.Columns(1).AutoFilter Field:=1, Operator:= _
        xlFilterValues, Criteria2:=Array(1, iMon & "/" & arrDays(iMon - 1) & "/2016")
'Gefilterte Zellen kopieren 'und am Zielort einfuegen. Spaltenoffset monatsabhaengig jeweils 3 Spalten versetzt.
Range("A1:B" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Sheets("Tabelle2").Range("a1").Offset(0, (iMon - 1) * 3)
'Gefilterte Zellen kopieren 'und am Zielort einfuegen. Spaltenoffset monatsabhaengig jeweils 3 Spalten versetzt.
Range("D1:D" & Cells(Rows.Count, 1).End(xlUp).Row).Copy Sheets("Tabelle2").Range("A1").Offset(0, (iMon - 1) * 3)
Application.CutCopyMode = False
End Sub

[Fennek]

Hallo,

sorry Stonemaus, ich halte die Fragestellung zwar nicht für gut, aber bei dem schlechten Fernsehprogramm eine kleine battle für den besten code zu führen, dafür ist das Thema gut.

Code:

Sub Stonemaus()
iMon = inputbox("Monat eingeben")
If iMon < 1 or iMon > 12 then msgbox "Fehler" : sStonemaus
iMon = int(iMon)
Sheets(2).usedrange.clear
Columns(1).numberformat = "M"
With sheets(1).usedrange
.autofilter field=:1, criteria1:=iMon
.specialcells(xlvisible).copy sheets(2).cells(1,1)
.autofilter
End with
Columns(1).numberformat = "dd.MM.yyyy"
End sub

[atilla]

Hallo,

von mir auch eine Variante.

Voraussetzung:
-Quelltabelle heißt: Tabelle1 und die Daten beginnen ab Zeile 2; in Zeile 1 Überschriften?
-Zieltabelle heißt: Tabelle2

Der Code löscht alle Zellen in Tabelle2 und schreibt die Tage ab Zeile 2

Unten stehenden Code in ein Modul einfügen:

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 arrTage As Variant
 Dim arrDaten()
 Dim oDic As Object, dicZ As Object
 Set oDic = CreateObject("scripting.dictionary")

 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, "Warnung"
 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
   arrTage = Application.Transpose(oDic.items)
   ReDim arrDaten(2, oDic.Count * 3 + oDic.Count)
   For i = 1 To oDic.Count
     For j = LBound(Split(arrTage(i, 1), "#")) To UBound(Split(arrTage(i, 1), "#")) - 1
       m = Application.Max(m, n)
       arrDaten(n, k) = vntQ(Split(arrTage(i, 1), "#")(j), 1)
       arrDaten(n, k + 1) = vntQ(Split(arrTage(i, 1), "#")(j), 2)
       arrDaten(n, k + 2) = vntQ(Split(arrTage(i, 1), "#")(j), 4)
       n = n + 1
     Next j
     n = 0
     k = k + 4
   Next i
   
   With Sheets("Tabelle2")
     .Cells.ClearContents
     .Cells(2, 1).Resize(m + 1, oDic.Count * 3 + oDic.Count) = (arrDaten)
   End With
 Else
   MsgBox "Keine Daten für gesuchten Monat!"
 End If
 
End Sub

Mit diesen Quelldaten:

Arbeitsblatt mit dem Namen 'Tabelle1'
	A	B	C	D
1	datum	wertB		wertd
2	01.01.2016	wertB1		wertd1
3	02.01.2016	wertB2		wertd2
4	03.01.2016	wertB3		wertd3
5	04.01.2016	wertB4		wertd4
6	05.01.2016	wertB5		wertd5
7	01.01.2016	wertB6		wertd6

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

erhalte ich verkürzt dargestellt folgende Ausgabe in Tabelle2:

Arbeitsblatt mit dem Namen 'Tabelle2'
	A	B	C	D	E	F	G	H	I	J	K
1
2	01.01.2016	wertB1	wertd1		02.01.2016	wertB2	wertd2		03.01.2016	wertB3	wertd3
3	01.01.2016	wertB6	wertd6
4

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

[Fennek]

Hallo,

Dieser Code ist zwar deutlich schlechter als erhofft (Specialfilter.copy funktioniert nicht mit dem geänderten NumberFormat). Aber es ist eine weitere Variante, die auch leicht Duplikate entfernen kann.

Code:

Sub sStonemaus2()
Dim iMon as integer
Sheets(2).clear
Sheets(1).columns("d:m").clear
lr = cells(rows.count, "A").end(xlup).row
iMon = inputbox("Monat eingeben (1-12)")
If iMon < 1 or iMon > 12 then msgbox "Fehler" : sStonemaus2
Cells(1,4) = "Monat"
Cells(1,6) = "Monat"
Cells(2,6) = iMon
Range("d2").formula = "=month(a2)"
Range("d2").select
Selection.autofill destination:=range(activecell, cells(lr, 4))
Range(cells(2,4), cells(lr, 4)).select
Selection.value = selection.value
Range("a1").currentregion.select
Selection.advancedfilter action:=xlfiltercopy, criteriarange:=range("f1:f2"), _
     CopytoRange:=sheets(2).range("a1"), unique:=true
Sheets(1).cells(1,1).select
Sheets(1).columns("d:m").clear
End sub

[schauan]

Hallo fennek,

ich hoffe, der TE hat Deinen Code noch nicht ausgeführt. Schaue mal in die Fragestellung. Er möchte die Daten aus den Spalten A, B und D kopieren und Du nutzt Spalte D für "Deinen" Spezialfilter. Außerdem fehlt der Versatz für die einzelnen Monate im Zielblatt.

[atilla]

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.