PDA

Vollständige Version anzeigen : Daten in anderes sheet per vba kopieren


surfenhawaii
26.09.2016, 12:07
Hallo,


Ich habe 2 sheets

im ersten sheet (Sheet1) sind zwei Spalten (Name und Datum)

Meier- 01.02.2016
Müller 02.02.2016
Arte-- 03.02.2016
------- 04.02.2016
------- 05.02.2016


Nun würde ich gerne diese Daten in ein zweites sheet (sheet2) rüberkopieren
Dies sollte so maussehen: Spalte 1 Name untereinander genauso oft wie die Datumsreihe
und daneben in der zweiten Spalte das Datum
Dies sollte so aussehen:


Meier 01.02.2016
Meier 02.02.2016
Meier 03.02.2016
Meier 04.02.2016
Meier 05.02.2016
Müller 01.02.2016
Müller 02.02.2016
Müller 03.02.2016
Müller 04.02.2016
Müller 05.02.2016
Arte 01.02.2016
Arte 02.02.2016
Arte 03.02.2016
Arte 04.02.2016
Arte 05.02.2016



Public Sub Copy()
'Code für ein allgemeines Modul
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngZ As Long
Dim lngZZ As Long
Dim intS As Integer

Set wksQ = Worksheets("Daten") 'Quellblatt
Set wksZ = Worksheets("Ergebnis") 'Zielblatt
lngZZ = 1

With wksQ
For lngZ = 1 To .Range("A1000000").End(xlUp).Row
For intS = 1 To Worksheets("Daten").Range("C1").Value
wksZ.Cells(lngZZ, 1).Value = .Cells(lngZ, 1).Value

lngZZ = lngZZ + 1


Next
Next
End With
End Sub

Mit dieser Formel erhalte ich nur die Spalte mit den Namen.
Für die Spalte mit dem Datum mit dem Datum müsste dieses Script um eine Schleife erweitert werden.
Ich kriege das aber nicht hin

wer kann weiterhelfen?

Uwi63
26.09.2016, 12:42
Hallo,

probier's mal so:
Public Sub Copy()
'Code für ein allgemeines Modul
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Dim lngName As Long
Dim lngDatum As Long
Dim lngZ As Long
lngZ = 1

Set wksQ = Worksheets("Daten") 'Quellblatt
Set wksZ = Worksheets("Ergebnis") 'Zielblatt

For lngName = 2 To wksQ.Cells(Rows.Count, "A").End(xlUp).Row
For lngDatum = 2 To wksQ.Cells(Rows.Count, "B").End(xlUp).Row
wksZ.Cells(lngZ + 1, "A") = wksQ.Cells(lngName, "A")
wksZ.Cells(lngZ + 1, "B") = CDate(wksQ.Cells(lngDatum, "B"))
lngZ = lngZ + 1
Next lngDatum
Next lngName

Set wksQ = Nothing
Set wksZ = Nothing

End Sub

surfenhawaii
26.09.2016, 12:51
Das ist super, Ich hatte mit viel komplizierteren Lösungen gearbeitet.

vielen Dank. it works:-)