Live-Forum - Die aktuellen Beiträge
Datum
Titel
29.03.2024 13:14:12
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
248to252
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
248to252
248to252
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Markierungen in unterschiedliche Bereiche kopieren

Markierungen in unterschiedliche Bereiche kopieren
28.04.2003 13:59:16
Thomas
Hallo zusammen,
ich knobel jetzt schon seit geraumer Zeit an folgendem Problem rum - vielleicht kann mir da ein Könner helfen:
Auf einem Arbeitsblatt (Tb1) habe ich einen "Terminplan" mit den Datums in Spalte A. In den Spalten B - D stehen weitere Werte (name, Zeit...)
Ich möchte nun die den Bereich, der jeweils das selbe Datum enthält in ein zweites Arbeitsblatt an eine bestimmte Stelle kopieren (z.B. alle Zeilen mit Datum 28.04.03 nach A1; alle Zeilen mit 29.04.03 nach D1)
Mit einem Makro habe ich es jetzt schon geschaft, daß mir mit einer Schleife die Werte mit gleichem Datum markiert werden. Die Frage ist jetzt: wie schaffe ich es jetzt, daß die erste Markierung an die und die zweite Markierung an eine andere Stelle usw. kopiert werden soll?

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Markierungen in unterschiedliche Bereiche kopieren
29.04.2003 00:28:53
jolly

Hallo Thomas,

ich hoffe diese Lösung kannst Du gebrauchen. Habe die Spalte E als Hilfsspalte genommen (wenn Du diese ändern willst, kannst du die 5 in den ...Cells(..,5) durch eine andere Spalte ändern.
Wenn Du die 1er nicht willst, kannst Du ja diese dann am Ende nach dem letzten Next durch eine Spalten-Löschroutine entfernen.

Gruß

jolly

Sub test()
Dim mydatum As Date
Dim i%, k%, l%, m%, lR%, lc%
lR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row
l = 1
k = 1

For i = 2 To lR Step 1

If Worksheets("Tabelle1").Cells(i, 5) <> 1 Then
mydatum = Worksheets("Tabelle1").Cells(i, 1)

If Worksheets("Tabelle2").Cells(1, 1) = Empty Then
lc = 1
Else
Do Until Worksheets("Tabelle2").Cells(1, lc) = ""
lc = lc + 1
Loop
End If

If Worksheets("Tabelle1").Cells(i, 5) <> 1 Then
For k = 2 To lR Step 1
If Worksheets("Tabelle1").Cells(k, 1) = mydatum Then
Worksheets("Tabelle2").Cells(l, lc) = Worksheets("Tabelle1").Cells(k, 2).Value
Worksheets("Tabelle2").Cells(l, lc + 1) = Worksheets("Tabelle1").Cells(k, 3).Value
Worksheets("Tabelle2").Cells(l, lc + 2) = Worksheets("Tabelle1").Cells(k, 4).Value
l = l + 1
ActiveSheet.Cells(k, 5) = 1
End If
Next k
End If
End If
Next i

End Sub

Anzeige
Re: Markierungen in unterschiedliche Bereiche kopieren
29.04.2003 00:47:21
jolly

kleiner fehler unterlaufen.... grrr..
hier der Code, welches funktionieren sollte. Ist halt schon zu spät.

Gruß

jolly


Sub test()
Dim mydatum As Date
Dim i%, k%, l%, m%, lR%, lc%
lR = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

For i = 2 To lR Step 1
l = 1
k = 1
If Worksheets("Tabelle1").Cells(i, 5) <> 1 Then
mydatum = Worksheets("Tabelle1").Cells(i, 1)

If Worksheets("Tabelle2").Cells(1, 1) = Empty Then
lc = 1
Else
Do Until Worksheets("Tabelle2").Cells(1, lc) = ""
lc = lc + 1
Loop
End If

If Worksheets("Tabelle1").Cells(i, 5) <> 1 Then
For k = 2 To lR Step 1
If Worksheets("Tabelle1").Cells(k, 1) = mydatum Then
Worksheets("Tabelle2").Cells(l, lc) = Worksheets("Tabelle1").Cells(k, 2).Value
Worksheets("Tabelle2").Cells(l, lc + 1) = Worksheets("Tabelle1").Cells(k, 3).Value
Worksheets("Tabelle2").Cells(l, lc + 2) = Worksheets("Tabelle1").Cells(k, 4).Value
l = l + 1
ActiveSheet.Cells(k, 5) = 1
End If
Next k
End If
End If
Next i

End Sub

Anzeige
Re: Markierungen in unterschiedliche Bereiche kopieren
29.04.2003 15:35:17
Thomas

Hallo jolly,
vielen vielen Dank für Deine nahezu geniale Lösung (und das um die Uhrzeit...) Ich würde das egal zu welcher Tageszeit nicht mal annähernd schaffen.
Ich habe damit jedoch noch folgendes Problem: Es schreibt mir jetzt alle "Terminblöcke" nebeneinander (jeweils versetzt rechts daneben). Was ich bräuchte wäre, daß es sozusagen den 2. Terminblock neben den ersten setzt und den 3. Terminblock mit einer Leerzeile untern den ersten, den 4. unter den 2. usw. Ziel für mich wäre es letztendlich die Termine dann auf einer DIN A4 Seite übersichtlich darzustellen.
Wenn Dir dazu was einfallen würde wäre das total genial!

Ciao, Thomas



Anzeige
Re: Markierungen in unterschiedliche Bereiche kopieren
29.04.2003 16:56:00
jolly

Hallo Thomas,

leider verstehe ich deine Anforderung nicht ganz. Kannst Du es irgendwie anders darstellen?

Gruß

jolly

Re: Markierungen in unterschiedliche Bereiche kopieren
29.04.2003 17:35:25
Thomas

Hallo jolly,
...werde mich bemühen! Läßt sich aber nicht so einfach hier schreiben.
Tabelle 1 mit den Grunddaten sieht so aus:
(Datum = Spalte A; Text1 = Spalte B; Text2 = Spalte C; Text 3 = Spalte D)

28.04.03 aaa bbb ccc
28.04.03 xxx yyy zzz
28.04.03 uuu iii ooo
29.04.03 qqq www eee
29.04.03 ccc vvv bbb
30.04.03 nnn mmm kkk

In Tabelle 2 soll das ganze dann in Blöcken dargestellt werden. Ich schreibe hier mal wie es ideal wäre - nämlich das jeweilige Datum als überschrift - muß aber nicht sein, könnte auch vor jeder Zeile stehen:

Montag, 28.04.03............................Dienstag, 29.04.03
28.04.03 aaa bbb ccc................29.04.03 qqq www eee
28.04.03 xxx yyy zzz.....................29.04.03 ccc vvv bbb
28.04.03 uuu iii ooo

Mittwoch, 30.04.03
30.04.03 nnn mmm kkk..................Hier wäre dann der 01.05.

Hier dann der 02.05.

Im Prinzip soll das ganze so eine Art "Stundenplan" für jeweils eine Woche (5 -6 Werktage) sein - jeweils auf einer DiN A4 Seite.

Danke, daß Du Dir's nochmal anschauen willst!
Schönen Abend, Thomas







Anzeige
Re: Markierungen in unterschiedliche Bereiche kopieren
29.04.2003 20:01:04
jolly

Hallo Thomas,

sorry für die Verspätung. Musste leider in eine dringende Konferenz. Jetzt kurz Feierabend noch schnell für dich:

Gruß

jolly


Option Explicit

Sub test()
Dim mydatum As Date
Dim i, k, l, m, n, lR, lc, row1, row2, z As Integer
lR = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
lc = 1
l = 2

For i = 2 To lR Step 1

If Worksheets("Tabelle1").Cells(i, 5) <> 1 Then
mydatum = Worksheets("Tabelle1").Cells(i, 1)
Worksheets("Tabelle2").Cells(l - 1, lc) = mydatum
z = l
For k = 2 To lR Step 1
If Worksheets("Tabelle1").Cells(k, 1) = mydatum Then
Worksheets("Tabelle2").Cells(l, lc) = Worksheets("Tabelle1").Cells(k, 2)
Worksheets("Tabelle2").Cells(l, lc + 1) = Worksheets("Tabelle1").Cells(k, 3)
Worksheets("Tabelle2").Cells(l, lc + 2) = Worksheets("Tabelle1").Cells(k, 4)
l = l + 1
ActiveSheet.Cells(k, 5) = 1
End If
Next k
If lc = 4 Then
If Worksheets("Tabelle2").Cells(2, 4) <> Empty Then
row1 = Worksheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row
row2 = Worksheets("Tabelle2").Cells(Rows.Count, 4).End(xlUp).Row
If row1 >= row2 Then
l = row1 + 2
MsgBox ("Row1" & row1)
Else
l = row2 + 2
MsgBox ("Row2" & row2)
End If

End If
lc = 1
Else
lc = 4
l = z
End If
End If
Next i

Worksheets("Tabelle1").Cells(1, 5).EntireColumn.Delete
End Sub

Anzeige
Re: Markierungen in unterschiedliche Bereiche kopieren
29.04.2003 23:08:11
jolly

Habe zu Hause bemerkt, dass die Leerzeilen fehlen.

Gruß

jolly

_____________________________________________________________
Option Explicit

Sub test()
Dim mydatum As String
Dim i, k, l, lR, lc, row1, row2, z As Integer
lR = Worksheets("Tabelle1").Cells(Rows.Count, 1).End(xlUp).Row
lc = 1
l = 2
row1 = 0
row2 = 0

For i = 2 To lR Step 1

If Worksheets("Tabelle1").Cells(i, 5) <> 1 Then
mydatum = Worksheets("Tabelle1").Cells(i, 1)
Worksheets("Tabelle2").Cells(l - 1, lc) = mydatum
z = l
For k = 2 To lR Step 1
If Worksheets("Tabelle1").Cells(k, 1) = mydatum Then
Worksheets("Tabelle2").Cells(l, lc) = Worksheets("Tabelle1").Cells(k, 2)
Worksheets("Tabelle2").Cells(l, lc + 1) = Worksheets("Tabelle1").Cells(k, 3)
Worksheets("Tabelle2").Cells(l, lc + 2) = Worksheets("Tabelle1").Cells(k, 4)
l = l + 1
ActiveSheet.Cells(k, 5) = 1
End If
Next k
If lc = 4 Then
If Worksheets("Tabelle2").Cells(2, 4) <> Empty Then
row1 = Worksheets("Tabelle2").Cells(Rows.Count, 1).End(xlUp).Row
row2 = Worksheets("Tabelle2").Cells(Rows.Count, 4).End(xlUp).Row
If row1 >= row2 Then
l = row1 + 3
MsgBox ("Row1" & row1)
Else
l = row2 + 3
MsgBox ("Row2" & row2)
End If

End If
lc = 1
Else
lc = 4
l = z
End If
End If
Next i

Worksheets("Tabelle1").Cells(1, 5).EntireColumn.Delete
End Sub

Anzeige
Re: Markierungen in unterschiedliche Bereiche kopieren
30.04.2003 09:45:53
Thomas

Hallo jolly,
SUPER!!! - DANKE!!!!
Total genial - genau das wollte ich haben und vermute, daß ich das in 10 Jahren nicht geschafft hätte.
Ich versuche gerade Deinen Code zu verstehen (da kann ich ja ganz schön was lernen) aber so ganz steige ich bei den vielen Variablen noch nicht durch. Auch egal. Jedenfalls bist Du GENIAL!!!
Was ich aber überhaupt nicht verstehe - wozu braucht man eigentlich die MsgBox?
Vielen vielen Dank für Deine Mühe und Hilfe!!!

Thomas


Re: Markierungen in unterschiedliche Bereiche kopieren
30.04.2003 13:38:59
jolly

Hallo Thomas,

die MsgBoxen braucht man eigentlich nicht. Ich nutze diese zur Kontrolle, welche Variablen welchen Wert zu welchem Punkt besitzen. Damit kann ich sehen an welchem Punkt, warum evtl. eine Funktion falsche Werte liefert.

Also kannst du diese getrost löschen

Gruß

jolly

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige