Forum Oficjalnego Klubu Mitsubishi - MitsuManiaki

[igi]

Hej

Na naszym ukochanym forum bawimy się w typowanie wyników meczy. Wcześniej prowadził to Śruba i liczył ręcznie ale to roboty kupa i miał już dość. Przejąłem ja liczenie i kilka innych rzeczy sobie ułatwiłem za pomocą różnych makr i funkcji.

Została jeszcze 1 rzecz: (poniżej funkcyjka)

Sub analiza()
Dim i As Long, tekst As String

For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
tekst = Cells(i, 1)
tekst = Replace(tekst, ":", "-") 'zamiana dwukropka na pauze
If InStrRev(tekst, " ") > 0 Then Mid(tekst, InStrRev(tekst, " ")) = ";" 'zamiana ostatniej spacji na ;(pauze)


poz = InStr(tekst, ";")

Range(Cells(i, 2), Cells(i, 2)) = Val(Left(Right(tekst, Len(tekst) - poz), InStr(Right(tekst, Len(tekst) - poz), "-") - 1))

Range(Cells(i, 3), Cells(i, 3)) = Val(Mid(Right(tekst, Len(tekst) - poz), InStr(Right(tekst, Len(tekst) - poz), "-") + 1))

' Range(Cells(i, 2), Cells(i, 2 + Len(tekst) - Len(Replace(tekst, "-", "")))) = Split(tekst, "-")
If Cells(i, 1).Font.Bold = True Then Cells(i, 4) = "X"
Next i
'End With
'Next arkusz

End Sub

I teraz prośba: Jak zrobić z tego żeby to działało we wszystkich Arkuszach a nie tylko w 1

[jawlo]

Naniesione zmiany są pogrubione. Nie mam możliwości przetestować to bez danych wejściowych.


Sub analiza()
Dim i As Long, tekst As String

'uzyskanie liczby arkuszy
SheetCount = ActiveWorkbook.Sheets.Count

For j = 1 To SheetCount

For i = 2 To Sheets(j).Cells(Rows.Count, 1).End(xlUp).Row
tekst = Sheets(j).Cells(i, 1)
tekst = Replace(tekst, ":", "-") 'zamiana dwukropka na pauze
If InStrRev(tekst, " ") > 0 Then Mid(tekst, InStrRev(tekst, " ")) = ";" 'zamiana ostatniej spacji na ;(pauze)
poz = InStr(tekst, ";")

Range(Sheets(j).Cells(i, 2), Sheets(j).Cells(i, 2)) = Val(Left(Right(tekst, Len(tekst) - poz), InStr(Right(tekst, Len(tekst) - poz), "-") - 1))

Range(Sheets(j).Cells(i, 3), Sheets(j).Cells(i, 3)) = Val(Mid(Right(tekst, Len(tekst) - poz), InStr(Right(tekst, Len(tekst) - poz), "-") + 1))

' Range(Cells(i, 2), Cells(i, 2 + Len(tekst) - Len(Replace(tekst, "-", "")))) = Split(tekst, "-")
If Sheets(j).Cells(i, 1).Font.Bold = True Then Sheets(j).Cells(i, 4) = "X"
Next i
Next j

'End With
'Next arkusz

End Sub

[igi]

jawlo, <wow>

Dzięki prawie działa ale i tak dużo pomogło.

Resztę dopytam jak mogę na gg . Dzięki jeszcze raz


Sorki mój błąd. Działa wyśmienicie

[igi]

jawlo, jeszcze jedna prośba o makro które usuwa końcowe i początkowe spacje we wszystkich arkuszach. Dało by się jak byś miał wolną chwilę?