Auflistung in Tranchen

Hallo EXCEL-Freunde,
mit nachstehendem Code werden ermittelte Werte in den Spalten C und D
untereinander aufgelistet (bis zu 600). Für die Vorbereitung eines Ausdrucks im
Querformat soll die Auflistung nach unten aber immer bei der Zeile 41 aufhören
und dann bei Zeile 2 und zwei spalten weiter rechts wieder beginnen.
Mit CountIf kann ich zwar feststellen, wie viele Zellen belegt werden,
ich kriege aber das Ende nach Zeile 41 nicht hin:
Sub auflisten()
Dim Z As Range, Anz1 As Integer, Anz2 As Integer, Anz3 As Integer
Dim lZiel As Long
Dim adr As Range
TabAuswahl
Set adr = Worksheets("Tabelle1").Range("D2:D700")
Anz1 = Application.WorksheetFunction.CountIf(adr, "O")
Anz2 = Application.WorksheetFunction.CountIf(adr, "V")
Anz3 = Anz1 + Anz2
MsgBox Anz3
For Each Z In Sheets("Tabelle1").Range("D2:D640")
If Z.Value = "V" Or Z.Value = "O" Then
lZiel = Sheets("Gefunden").Range("D65536").End(xlUp).Row + 1
Sheets("Gefunden").Cells(lZiel, Z.Column) = Sheets("Tabelle1").Cells(Z.Row, Z.Column)
Sheets("Gefunden").Cells(lZiel, Z.Column - 1) = Sheets("Tabelle1").Cells(Z.Row, Z.Column - 2)
End If
Next
End Sub
Sub TabAuswahl() ' prüfen ob neue Tabelle angelegt werden muss
Dim Sh As Worksheet
Dim sName$
sName = "Gefunden"
For Each Sh In Worksheets
If InStr(Sh.Name, sName) > 0 Then
Sh.Select
Exit Sub
End If
Next Sh
Sheets.Add.Name = ("Gefunden")
End Sub

Besten Dank für eine Hilfe!
mfg
Private Tippgemeinschaft für Lotto oder KENO: http://www.kenostrategen.de

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Erich,
besten Dank. Das mit der Spalte B war Absicht, weil hier die relevanten Daten stehen.
Habe die Übertragung noch um eine Spalte erweitert und um eine nach links versetzt:


Sub auflisten()
Dim Z As Range
Dim lZiel As Long, sZiel As Integer
TabAuswahl
sZiel = Cells(41, Columns.Count).End(xlToLeft).Column
If sZiel < 4 Then sZiel = 4
lZiel = Cells(Rows.Count, sZiel).End(xlUp).Row
If lZiel = 41 Then
sZiel = sZiel + 3
lZiel = Cells(Rows.Count, sZiel).End(xlUp).Row
End If
For Each Z In Sheets("Erfassung").Range("D2:D2000")
If Z.Value = "V" Or Z.Value = "O" Then
lZiel = lZiel + 1
If lZiel > 41 Then
sZiel = sZiel + 3
lZiel = 2
End If
Cells(lZiel, sZiel - 1) = Z
Cells(lZiel, sZiel - 2) = Z.Offset(0, -2)
Cells(lZiel, sZiel - 3) = Z.Offset(0, -3)
End If
Next
End Sub

So sieht das Ergebnis aus (Auszug):

Gefunden

	A	B	C	D	E	F	G	H	I
1
2	A_1TM	Ried	V	DK_1SAS	Esbjerg fB	V	FinnlandY	MP ja	V
3	A_1TM	Mattersburg	V	DK_1SAS	Bröndby Kopenhagen	V	FinnlandY	TP-47	V
4	A_1TM	Sturm Graz	V	DK_1SAS	Aalborg BK	V	FinnlandK_A	FCV ja ?	V
5	A_1TM	Rheindorf Altach	V	DK_1SAS	FC Nordsjælland	V	FinnlandK_A	Kontu	V
6	A_1TM	Rapid Wien	V	DK_1SAS	AC Horsens	V	FinnlandK_A	KuPS Ak.	V
7	A_1TM	FC Superfund Pasching	V	DK_1SAS	Viborg	V	FinnlandK_A	KäPa	V
8	A_1TM	FC Wacker Tirol	V	DK_1SAS	Vejle	V	FinnlandK_A	LPS	V
9	A_1TM	Salzburg	V	DK_1SAS	Randers FC	V	FinnlandK_B	KaaPo	V
10	A_2RZ	Kapfenberg	V	DK_1SAS	FC Kopenhagen	V	FinnlandK_B	P-Iirot	V

Diagramm - Grafik - Excel Tabellen einfach im Web darstellen Excel Jeanie HTML 3.0 Download
Jetzt bräuchte ich noch eine Ergänzung:
In den Spalten A, D, G usw. (also die erste Spalte und dann in jeder 3. Spalte) sollen
die Zellen gelöscht werden, die mit der Zelle oberhalb den gleichen Namen haben
(wird übersichtlicher und ich erspar mir Zeit beim ausdrucken).
Meine Versuche waren aber erfolglos; es gäbe bestimmt auch was in der Recherche,
vielleicht kannst Du das noch einbauen.
Besten Dank schon mal!
mfg
Private Tippgemeinschaft für Lotto oder KENO: http://www.kenostrategen.de

Sub auflisten() Dim Z As Range Dim lZiel As Long, sZiel As Integer, Inhalt As String TabAuswahl sZiel = Cells(41, Columns.Count).End(xlToLeft).Column If sZiel < 4 Then sZiel = 4 lZiel = Cells(Rows.Count, sZiel).End(xlUp).Row If lZiel = 41 Then sZiel = sZiel + 3 lZiel = Cells(Rows.Count, sZiel).End(xlUp).Row End If For Each Z In Sheets("Erfassung").Range("D2:D2000") If Z.Value = "V" Or Z.Value = "O" Then lZiel = lZiel + 1 If lZiel > 41 Then sZiel = sZiel + 3 lZiel = 2 End If Cells(lZiel, sZiel - 1) = Z Cells(lZiel, sZiel - 2) = Z.Offset(0, -2) If Inhalt <> Z.Offset(0, -3) Or lZiel = 2 Then Inhalt = Z.Offset(0, -3) Cells(lZiel, sZiel - 3) = Z.Offset(0, -3) End If End If Next End Sub

Beliebteste Forumthreads (12 Monate)

5 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

5
Beiträge zum Forumthread

Beiträge zu diesem Forumthread