Live-Forum - Die aktuellen Beiträge
Datum
Titel
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

Schleife erweitern

Schleife erweitern
27.04.2003 01:31:57
Rolf St.
Hallo !
Könnt ihr mir ' If k = m Then in folgendes Makro richtig einfügen? Ich kriege das nicht hin.

Dim i As Integer, j As Integer, k As Integer, m As Integer

m = Application.InputBox("Wie viele Teilnehmer gehören zu einer Mannschaft ?", "Gleiche eingeben", 6, Type:=1)
If m <= 0 ThenExit Sub
End If

i = 2
j = 2
Do While Cells(i, 11) <> ""
k = 1
Do While Cells(i, 11) = Cells(j, 11)
j = j + 1
k = k + 1
Loop
If k <> m Then
If k < m Then
' If k = m Then ' An dieser Stelle funktioniert dann nur gleich
Rows(i & ":" & j - 1).Delete Shift:=xlUp
Else
Rows(i + m & ":" & j - 1).Delete Shift:=xlUp
i = i + m
End If
j = i + 1
Else
i = i + m
j = i + 1
End If
Loop

Vielen Dank!

Tschüß
Rolf


12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Schleife erweitern
27.04.2003 02:28:27
moe

Hallo Rolf so müsste es gehen
Gruss
moe
Sub test()
Dim i As Integer, j As Integer, k As Integer, m As Integer

m = Application.InputBox("Wie viele Teilnehmer gehören zu einer Mannschaft ?", "Gleiche eingeben", 6, Type:=1)
If m <= 0 Then Exit Sub


i = 2
j = 2
Do While Cells(i, 11) <> ""
k = 1
Do While Cells(i, 11) = Cells(j, 11)
j = j + 1
k = k + 1
Loop
If k <> m Then
If k < m Then
If k = m Then ' An dieser Stelle funktioniert dann nur gleich
Rows(i & ":" & j - 1).Delete Shift:=xlUp
Else
Rows(i + m & ":" & j - 1).Delete Shift:=xlUp
i = i + m
End If
j = i + 1
Else
i = i + m
j = i + 1
End If
End If
Loop

End Sub

Anzeige
Re: Schleife erweitern
27.04.2003 08:12:55
Rolf St.

Hallo Moe!
Vielen Dank für deine Hilfe!

Leider funktioniert es noch nicht. Hier die Erläuterung wie das Makro läuft.
In Spalte K stehen unterschiedlich viele gleiche Zahlen untereinander, die je nach Eingabe in der Inputbox bearbeitet werden.
Ist die Eingabe in die Inputbox > als die Anzahl gleicher Zahlen in Spalte K werden alle Zeilen gelöscht.
Ist die Eingabe in die Inputbox < als die Anzahl gleicher Zahlen in Spalte K werden die restlichen Zeilen nach dem Eingabewert gelöscht (das heißt, wenn Eingabezahl Inputbox 3 ist und 5 gleiche Zahlen, in Spalte K stehen, werden die ersten drei gleichen stehen gelassen und die letzten zwei Zeilen gelöscht)

Das Problem:
Wenn ich in die Inputbox eine Zahl eingebe, die gleich der Anzahl der Zahlen in Spalte K ist funktioniert das Makto nicht richtig.
Beispiel: In Spalte K stehen 20 Mannschaften untereinander. Mannschaft 1, 2 ,3 ,4 usw mit je 6 Mannschafstmitgliedern also 6 mal die Zahl 1, 6 mal die Zahl 2 usw. Wenn ich das Makro starte, wird von den ersten Mannschaft die 6te Zahl gelöscht (es sollen aber 6 Zahlen stehen bleiben) und von der zweiten Mannschaft
bleibt nur die erste Zahl stehen, alle nachfolgenden Mannschaften werden richtig mit 6 gleichen Zahlen dargestellt.

Vielleicht kannst du mir ja noch mal helfen?

Tschüß
Rolf





Anzeige
Re: Schleife erweitern
27.04.2003 09:06:34
andre

hallo rolf,
wieso stehen bei 20 mannschaften nur 6x die 1 ... ?
also 20 manschaften haben doch alle mindestens 1x di 1, also 20x die 1 oder?
wenn alle 20 mannschaften 6 spieler haben, dann steht dort auch 20x die 6 oder?
also 123456123456123456... usw oder wie sieht das aus?
gruss andre

Re: Schleife erweitern
27.04.2003 11:46:40
Rolf St.

Hallo Andre!
Es gibt z. B. 20 Mannschaften a 6 Personen. Jede Mannschaft erhält eine Mannschaftsnummer. Das heißt es gibt 6 Personen mit der 1, 6 Personen mit der 2, 6 Personen mit der 3, usw. Das heißt es gibt einmal die 12345789 usw.
Es gibt auch Veranstaltungen in denen unterschiedlich viele Personen zu einer Mannschaft gehören und nur die drei schnellsten jeder Mannschaft gewertet werden. Bei den meisten Veranstaltungen bilden drei Teilnehmer eine Mannschaft.


Gruß
Rolf




Anzeige
Re: Schleife erweitern
27.04.2003 12:46:22
andre

hallo rolf,
hier erst mal eine unfertige variante - muss jetzt leider weg.
im ersten teil wird der bereich durchsucht und bedingungen gesetzt - (bei mir spalte a). die sind noch nicht exakt.
für das löschen erstelle ich dann gesonderte funktionen.

Public Sub test()
start = 0
m = Application.InputBox("Wie viele Teilnehmer gehören zu einer Mannschaft ?", "Gleiche eingeben", 6, Type:=1)
If m <= 0 Then Exit Sub
i = 2
Do While Cells(i, 1) <> ""
If start = 0 Then start = i
If Cells(i + 1, 1) < Cells(i, 1) And Cells(i + 1, 1) <> "" And Cells(i, 1) < m Then
loescheMannschaft start, i
End If
If Cells(i, 1) > m Then
loescheSpieler i
i = i - 1
End If
i = i + 1
Loop
Exit Sub

End Sub
Private Sub loescheMannschaft(start, i)
Rows(start & ":" & i).Delete Shift:=xlUp
End Sub

Private Sub loescheSpieler(i)
Rows(i).Delete Shift:=xlUp
End Sub

gruss andre

Anzeige
Re: Schleife erweitern
27.04.2003 17:35:25
andre

hallo rolf,
war anscheinend nur eine bedingung zu viel:
statt
If Cells(i + 1, 1) < Cells(i, 1) And Cells(i + 1, 1) <> "" And Cells(i, 1) < m Then
nimm
If Cells(i + 1, 1) < Cells(i, 1) And Cells(i, 1) < m Then

gruss andre


Re: Schleife erweitern
27.04.2003 18:38:22
Rolf St.

Re: Schleife erweitern
27.04.2003 19:55:21
andre

hallo rolf,
versuch's mal so:

Public Sub test2()
m = Application.InputBox("Wie viele Teilnehmer gehören zu einer Mannschaft ?", "Gleiche eingeben", 6, Type:=1)
If m <= 0 Then Exit Sub
j = Cells(Rows.Count, 1).End(xlUp).Row
For i = 1 To 20
k = Application.WorksheetFunction.CountIf(Range("a2:A" & j), i)
If k = 0 Then GoTo ende
    
    Range("a:a").Select
    Selection.Find(What:=i, After:=[a1], LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate
start = ActiveCell.Row

If k < m Then
loescheMannschaft start, start + k - 1
End If
If k > m Then
loescheMannschaft start + m, start + k - 1
End If
ende:
Next

End Sub
 

     Code eingefügt mit Syntaxhighlighter 1.16

du brauchst noch loeschemannschaft dazu, loeschespieler entfällt. ich nehme mal an, dass die ganze zeile weg muss oder? da muss loeschemannschaft angepasst werden.
gruss andre


Anzeige
Re: Schleife erweitern
27.04.2003 21:09:00
Rolf St.

Hallo Andre!
Das Makro läuft super!!

Jetzt habe ich noch ein kleines Problem mit Teilnehmern
die nicht an der Mannschaftswertung teilnehmen und deshalb auch keine Mannschaftsnummer haben. Die Zeilen müßten gelöscht werden.

Wenn in Spalte B ein Wert steht und in Spalte A in der jeweiligen Zelle nichts steht, soll die Zeile gelöscht werden.

Vielleicht kannst du mir hier noch einmal helfen ?

Tschüß
Rolf

Re: Schleife erweitern
28.04.2003 05:53:46
andre

hallo rolf,
zuerst noch mal zu meiner letzten antwort - in loeschemannschaft wird die zeile gelöscht, hast du ja inzwischen positiv gemerkt.
mein makro läuft nur fehlerfrei, wenn zumindest die mannschaften zumindest mit den zahlen sortiert sind. also ein paar einsen, dann zweien, dann wieder einsen und es kommt unsinn raus. die "sortierung" in der tabelle kommt durch die reihenfolge der eintragung, nehme ich an.
da können die leeren also mal mittendrin und mal am ende oder anfang stehen.
ich hole mir daher die "länge" der spalte aus B und untersuche damit a

j = Cells(Rows.Count, 2).End(xlUp).Row
for i=j to 2 step -1
if cells(i,1)="" then rows(i & ":" & i).delete Shift:=xlUp
next

das kannst du z.b. am ende vor end sub einfügen.

gruss andre

Anzeige
Re: Schleife erweitern
28.04.2003 23:40:36
Rolf St.

Hallo Andre!
Hier nun das fast fertige Makro und es läuft!

Public Sub mannschaftswertung19012002()
Dim lgRow As Long
Dim lgCount As Long
Dim l As Long
Dim Letzte As Long
Dim start As Variant
Dim p As Integer
Dim u As Integer
Dim i As Integer, j As Integer, k As Integer, t As Integer, s As Integer, h As Variant, r As Integer, b As Variant
Dim intCounter As Integer, LetzteZelle As Integer, Anfang As Integer

Application.ScreenUpdating = False
ActiveWindow.ScrollWorkbookTabs Position:=xlLast

' Löschen
Sheets("mannschaft").Select
Range("A2:O1000").Select
Selection.ClearContents

' holt aus Tabellenblatt
Sheets("Zeitnahme").Select
Range("A2:M1000").Select
Selection.Copy
ActiveWindow.ScrollWorkbookTabs Sheets:=-5

' fügt ein
Sheets("mannschaft").Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Application.CutCopyMode = False

' sortiert
Dim x%
Selection.Sort Key1:=Range("K2"), _
Order1:=xlAscending, Key2:=Range("D2"), _
Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom

' löscht Zeilen wenn in
p = Cells(Rows.Count, 2).End(xlUp).Row
For u = p To 2 Step -1
If Cells(u, 11) = "" Then Rows(u & ":" & u).Delete Shift:=xlUp
Next

Application.ScreenUpdating = True
m = Application.InputBox("Wie viele Teilnehmer gehören zu einer Mannschaft ?", "Gleiche eingeben", 6, Type:=1)
If m <= 0 Then Exit Sub

'wichtig für Makro Urkundendruck
Range("X1").Value = m
' Kopieren

j = Cells(Rows.Count, 11).End(xlUp).Row
For i = 1 To 1000
A = Application.WorksheetFunction.CountIf(Range("k2:K" & j), i)
If A = 0 Then GoTo ende

Range("k:k").Select
Selection.Find(What:=i, After:=[k1], LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False).Activate
start = ActiveCell.Row
If A < m Then
loescheMannschaft start, start + A - 1
End If
If A > m Then
loescheMannschaft start + m, start + A - 1
End If
ende:
Next

Range("N2").Select
For zi = 1 To m Step 1
formel = "=SUM(R[" & (1 - zi) & "]C[-10]:R[" & (m - zi) & "]C[-10])"
ActiveCell.FormulaR1C1 = formel
Range("N" & (2 + zi)).Select
Next

Range("N2:N" & (1 + m)).AutoFill Destination:=Range("N2:N1000"), Type:=xlFillDefault
Range("N2:N1000").Select
ActiveWindow.LargeScroll Down:=-25

If [N1000] = "" Then
Letzte = [N1000].End(xlUp).Row
Else
Letzte = 1000
End If

On Error Resume Next
For A = 1 To Letzte
If Cells(A, 14) < CDate("0:0:1") Then Cells(A, 14).ClearContents
Next A

ActiveSheet.UsedRange.Select
zeilen = Selection.Rows.Count
' MsgBox (zeilen)
For A = zeilen To 1 Step -1
Next

Range("A2").Select
Selection.Sort Key1:=Range("N2"), _
Order1:=xlAscending, Key2:=Range("D2"), _
Order2:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom

h = Cells(Rows.Count, 2).End(xlUp).Row
For s = h To 2 Step -1
If Cells(s, 11) = "" Then Rows(s & ":" & s).Delete Shift:=xlUp
Next

LetzteZelle = Cells(Cells.Rows.Count, 11).End(xlUp).Row

Anfang = 2 'Alternativ Anfang = ActiveCell.Row

For intCounter = Anfang To LetzteZelle

If IsNumeric(Cells(intCounter - 1, 11)) Then

If Cells(intCounter, 11) <> Cells(intCounter - 1, 11) Then
Cells(intCounter, 11).Offset(0, 4) = _
Cells(intCounter, 11).Offset(-1, 4) + 1
Else
Cells(intCounter, 11).Offset(0, 4) = _
Cells(intCounter, 11).Offset(-1, 4)
End If
Else
Cells(intCounter, 11).Offset(0, 4) = 1
End If
Next intCounter

Application.ScreenUpdating = True
Range("A1").Select

End Sub

Private Sub loescheMannschaft(start, i)
Rows(start & ":" & i).Delete Shift:=xlUp
End Sub

Ne kleine Frage habe ich noch:

' zu Zeilen löschen
h = Cells(Rows.Count, 2).End(xlUp).Row
For s = h To 2 Step -1
If Cells(s, 11) = "" Then Rows(s & ":" & s).Delete Shift:=xlUp
Next

Wie du oben sehen kannst hole ich die Daten aus einem anderen Tabellenblatt. Wenn nun Spalte 11 Zellen stehen die zwar leer aussehen, aber nicht leer sind, werden Sie nicht gelöscht.
Ich lösche per Leertaste eine Zahl aus Spalte 11, diese wird dann nicht als leer erkannt. Erst ween ich rechte Maustaste Inhalte lösche arbeite wir die Zelle als leer erkannt.

Vielleicht hast du da noch mal eine Idee?

Vielen Dank!

Tschüß
Rolf



Anzeige
Re: Schleife erweitern
01.05.2003 10:22:04
andre

hallo rolf,
dann erweitere die bedingung auf
... or Cells(s, 11) = " " then ...
oder alternativ, falls auch mehr leerzeichen sein können
... or trim(Cells(s, 11) = " " then ...
eventuell kommt da ein fehler, wenn die zelle wirklich leer ist.
da müsstest du das in eine zusätzliche bedingung schreiben:
If Cells(s, 11) = "" Then
Rows(s & ":" & s).Delete Shift:=xlUp
elseif trim(Cells(s, 11) = "" then
Rows(s & ":" & s).Delete Shift:=xlUp
end if
gruss andre

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige