Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
884to888
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
884to888
884to888
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Text heraussuchen

Text heraussuchen
08.07.2007 11:40:08
Burghard
Hallo,
ich brauche mal Hilfe. Wir haben eine Familientippgruppe für die Bundesliga. Es geht nicht um Geld, sondern nur um den Spaß. Ich möchte dazu jeweils die einzelnen Mannschaften aus den Spieltagen in einen Block (mit den getippten Ergebnissen) bringen. Also alle Spiele des VfB Stuttgart in der Hinserie, alle Spiele von Bayern München etc., um dann später weiterrechnen zu können.
Als Beispiel habe ich die nur ersten vier Spieltage (gesamt sind dies 17) des Tabellenblatts "Tippzettel" genommen (Spieltage.jpg).
Userbild
Die Auswertung(stabelle) (siehe Auswertung.jpg) würde ich gerne in einem Tabellenblatt "Auswertung" unterbringen, da ich dort noch weiterrechnen will.
Userbild
Am liebsten wäre mir das Ganze als VBA.
Freue mich über jede Hilfe und danke schon einmal im Voraus.
Schönen Gruß
Burghard

4
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Text heraussuchen
08.07.2007 14:20:27
ransi
HAllo Burghard
Jetzt machst du dir die Mühe eine screenshot zu erstellen und den hochzuladen.
Der potenzielle Antworter soll sich jetzt aus diesem screenshot die Tabelle nachbauen und testen.
Warum lädst du nicht gleich die Tabelle hoch ?
ransi

AW: Text heraussuchen
09.07.2007 01:50:47
fcs
Hallo Burghard,
mit den folgenden Makros kannst die Tipps in die Auswertung übertragen. Entweder ein für einzelnes Team oder für alle Teams.
Gruß
Franz

Sub TippsNachAuswertung()
'Einzelnes Team mit Input-Box-Eingabe
Dim wksTipp As Worksheet, wksAus As Worksheet
Dim ZeileTipp&, ZeileAus&, ZeileMaxTipp&, i%
Dim SpalteGerade%, SpalteUngerade%
Dim Mannschaft
Set wksTipp = ActiveWorkbook.Worksheets("Spieltage")
Set wksAus = ActiveWorkbook.Worksheets("Auswertung")
ZeileAus = 1
SpalteGerade = 11 '1. Spalte der geraden Spieltage
SpalteUngerade = 1 '1. Spalte der ungeraden Spieltage
'Letzte Zeile mit Tipps
ZeileMaxTipp = wksTipp.Cells(wksTipp.Rows.Count, SpalteUngerade).End(xlUp).Row
ZeileTipp = 1
Mannschaft = InputBox("Welche Mannschaft nach Auswertung?" & vbLf & _
"Genaue Schreibweise beachten!!!", "Team nach Auswertung", "")
If Mannschaft = "" Then Exit Sub 'Abbrechen gewählt
With wksTipp
Do Until ZeileTipp > ZeileMaxTipp
If InStr(1, .Cells(ZeileTipp, SpalteUngerade), "Spieltag") > 0 Then
For i = 1 To 9
If .Cells(ZeileTipp + i, SpalteUngerade) = Mannschaft Or _
.Cells(ZeileTipp + i, SpalteUngerade + 1) = Mannschaft Then
ZeileAus = ZeileAus + 1
wksAus.Cells(ZeileAus, 1).Value = .Cells(ZeileTipp + i, SpalteUngerade)
wksAus.Cells(ZeileAus, 2).Value = .Cells(ZeileTipp + i, SpalteUngerade + 1)
wksAus.Cells(ZeileAus, 3).Value = .Cells(ZeileTipp + i, SpalteUngerade + 2)
wksAus.Cells(ZeileAus, 4).Value = ":"
wksAus.Cells(ZeileAus, 5).Value = .Cells(ZeileTipp + i, SpalteUngerade + 4)
Exit For
End If
Next i
For i = 1 To 9
If .Cells(ZeileTipp + i, SpalteGerade) = Mannschaft Or _
.Cells(ZeileTipp + i, SpalteGerade + 1) = Mannschaft Then
ZeileAus = ZeileAus + 1
wksAus.Cells(ZeileAus, 1).Value = .Cells(ZeileTipp + i, SpalteGerade)
wksAus.Cells(ZeileAus, 2).Value = .Cells(ZeileTipp + i, SpalteGerade + 1)
wksAus.Cells(ZeileAus, 3).Value = .Cells(ZeileTipp + i, SpalteGerade + 2)
wksAus.Cells(ZeileAus, 4).Value = ":"
wksAus.Cells(ZeileAus, 5).Value = .Cells(ZeileTipp + i, SpalteGerade + 4)
Exit For
End If
Next i
ZeileTipp = ZeileTipp + 9
End If
ZeileTipp = ZeileTipp + 1
Loop
End With
'Formate kopieren
With wksAus
ZeileMaxTipp = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A2:E3").Copy
For ZeileAus = 4 To ZeileMaxTipp Step 2
.Cells(ZeileAus, 1).Range("A1:E2").PasteSpecial Paste:=xlFormats
Next
Application.CutCopyMode = False
End With
End Sub
Sub TippsNachAuswertung2()
'Alle Teams hintereinander weg
Dim wksTipp As Worksheet, wksAus As Worksheet
Dim ZeileTipp&, ZeileAus&, ZeileMaxTipp&, i%
Dim SpalteGerade%, SpalteUngerade%, Spalte%, Zeile&
Dim Mannschaft
Set wksTipp = ActiveWorkbook.Worksheets("Spieltage")
Set wksAus = ActiveWorkbook.Worksheets("Auswertung")
ZeileAus = 1
SpalteGerade = 11 '1. Spalte der geraden Spieltage
SpalteUngerade = 1 '1. Spalte der ungeraden Spieltage
'Letzte Zeile mit Tipps
ZeileMaxTipp = wksTipp.Cells(wksTipp.Rows.Count, SpalteUngerade).End(xlUp).Row
For Spalte = 1 To 2
For Zeile = 2 To 10
ZeileTipp = 1
With wksTipp
Mannschaft = .Cells(Zeile, Spalte).Value
Do Until ZeileTipp > ZeileMaxTipp
If InStr(1, .Cells(ZeileTipp, SpalteUngerade), "Spieltag") > 0 Then
For i = 1 To 9
If .Cells(ZeileTipp + i, SpalteUngerade) = Mannschaft Or _
.Cells(ZeileTipp + i, SpalteUngerade + 1) = Mannschaft Then
ZeileAus = ZeileAus + 1
wksAus.Cells(ZeileAus, 1).Value = .Cells(ZeileTipp + i, SpalteUngerade)
wksAus.Cells(ZeileAus, 2).Value = .Cells(ZeileTipp + i, SpalteUngerade + 1)
wksAus.Cells(ZeileAus, 3).Value = .Cells(ZeileTipp + i, SpalteUngerade + 2)
wksAus.Cells(ZeileAus, 4).Value = ":"
wksAus.Cells(ZeileAus, 5).Value = .Cells(ZeileTipp + i, SpalteUngerade + 4)
Exit For
End If
Next i
For i = 1 To 9
If .Cells(ZeileTipp + i, SpalteGerade) = Mannschaft Or _
.Cells(ZeileTipp + i, SpalteGerade + 1) = Mannschaft Then
ZeileAus = ZeileAus + 1
wksAus.Cells(ZeileAus, 1).Value = .Cells(ZeileTipp + i, SpalteGerade)
wksAus.Cells(ZeileAus, 2).Value = .Cells(ZeileTipp + i, SpalteGerade + 1)
wksAus.Cells(ZeileAus, 3).Value = .Cells(ZeileTipp + i, SpalteGerade + 2)
wksAus.Cells(ZeileAus, 4).Value = ":"
wksAus.Cells(ZeileAus, 5).Value = .Cells(ZeileTipp + i, SpalteGerade + 4)
Exit For
End If
Next i
ZeileTipp = ZeileTipp + 9
End If
ZeileTipp = ZeileTipp + 1
Loop
End With
Next
Next
'Formate kopieren
With wksAus
ZeileMaxTipp = .Cells(.Rows.Count, 1).End(xlUp).Row
.Range("A2:E3").Copy
For ZeileAus = 4 To ZeileMaxTipp Step 2
.Cells(ZeileAus, 1).Range("A1:E2").PasteSpecial Paste:=xlFormats
Next
Application.CutCopyMode = False
End With
End Sub


Anzeige
AW: Text heraussuchen
10.07.2007 10:14:00
Burghard
Hallo Franz,
es ist der Wahnsinn! Supergut! Funktioniert erstklassig! Tausend Dank. Genau das hatte ich gesucht.
Ich habe mir einmal den Code angeschaut. Sagenhaft! Würde ich auch gerne können.
Vielen, vielen Dank!
Schönen Gruß
Burghard

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige