igi - 15-01-2010, 13:26 Temat postu: VBA EXCEL - prośba o poprawiene makro 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 - 16-01-2010, 12:23 Temat postu: Re: VBA EXCEL - prośba o poprawiene makro 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 - 16-01-2010, 19:35 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 - 02-04-2010, 10:24 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ę?
|
||||||
