Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Konkurs Mikołajowy

OShon · Wysłany: 27-11-2013, 20:17 **Konkurs Mikołajowy**

Na naszym portalu FB został ogłoszony konkurs mikołajkowy.

Udział w konkursie mogą brać wszystkie osoby, które polubiły ten środek komunikacji.
Zgłoszenia przyjmowane do soboty 7-go grudnia zwycięzce poznacie w niedzielę.

Do wygrania dowolnie wybrany dodatek VBATools.pl kat "za drobne".
Wybór jest szeroki ponieważ w puli tej jest 40 różnych rozwiązań.
Więcej szczegółów (np co do wymogów) w komentarzach na FB.

Do tej pory wzięli udział:
Kat Userowa

Patronus
bizzy_17
incognito

Kat Modkowa

Artik
TKuchta1
mkkk23
Worm
Rycho
Bodek
Quasi

Na Fejsie zamieściłem 9-pktów - jak testować swoją funkcję. Polecam, Poprawki mile widziane.

p.s. Uwaga kończymy nasz konkurs DZIŚ - także zamykać swoje projekciki i słać do analizy. Jutro ogłoszenie wyników. Fanfary, nagrody, uściski, itd.. inaczej mówiąc wszelkie wyróżnienia.

:: KONKURS ZAMKNIĘTY ::
Zwycięzcy na FB.

Oto najfajniejsze funkcje a zarazem najefektywniejsze:

Kod:

Function MinRng(rngSel As Range) As Range
Dim rng As Range

On Error Resume Next
With rngSel
Set rng = Intersect(.Cells, _
.SpecialCells(xlCellTypeConstants))
'Debug.Print "(1) " & rng.Address
Set rng = Union(rng, Intersect(.Cells, _
.SpecialCells(xlCellTypeFormulas)))
'Debug.Print "(2) " & rng.Address
Set rng = Intersect(rng, _
.SpecialCells(xlCellTypeVisible))
'Debug.Print "(3) " & rng.Address
End With
On Error GoTo 0

If rng Is Nothing Then Set rng = rngSel
Set MinRng = ContinuousRange(rng)
End Function

Function ContinuousRange(rngDiscont As Range) As Range
'---------------------------------------------------------------------------------------
' Procedure : ContinuousRange
' DateTime : 13.04.2013
' Author : Artik
' Purpose : Funkcja zwraca minimalny zakres ciągły
' zawierający nieciągły (rngDiscont)
'---------------------------------------------------------------------------------------
Dim minCol As Integer
Dim maxCol As Integer
Dim minRow As Long
Dim maxRow As Long
Dim iCol As Integer
Dim iCol1 As Integer
Dim lRow As Long
Dim lRow1 As Long
Dim rngArea As Range

minCol = rngDiscont.Column
minRow = rngDiscont.Row

For Each rngArea In rngDiscont.Areas
iCol = 0
iCol1 = 0
lRow = 0
lRow1 = 0

With rngArea
iCol = .Column
iCol1 = .Column + .Columns.Count - 1
lRow = .Row
lRow1 = .Row + .Rows.Count - 1
End With

If minCol > iCol Then minCol = iCol
If maxCol < iCol1 Then maxCol = iCol1
If minRow > lRow Then minRow = lRow
If maxRow < lRow1 Then maxRow = lRow1
Next rngArea

With rngDiscont.Parent
Set ContinuousRange = .Range(.Cells(minRow, minCol), .Cells(maxRow, maxCol))
End With
End Function

'-------------------------------------------------

Function R_min_range(sel As Range) As Range
'Rycho
Dim ws As Worksheet
Dim rg As Range
Dim kom As Range
Dim x1 As Long, y1 As Long
Dim x2 As Long, y2 As Long

On Error GoTo R_min_range_Error

'akusz wywoływany
Set ws = sel.Parent

'zaznaczony cały arkusz
If sel.Columns.Count = Columns.Count And _
sel.Rows.Count = Rows.Count Then
Set sel = ws.UsedRange
End If

'zaznaczona jedna komórka
If sel.Count = 1 Then
Set R_min_range = sel
GoTo R_min_range_Exit
End If

'używane komórki w zaznaczonym zakresie
Set rg = Intersect(sel, ws.UsedRange)

'zaznaczony zakres bez danych
If WorksheetFunction.CountA(sel) = 0 Then
Set R_min_range = sel
GoTo R_min_range_Exit
End If

'najdalsza używana komórka
With sel.SpecialCells(xlCellTypeLastCell)
x1 = .Column
y1 = .Row
End With

'komórka używana najbliższa A1
With ws.UsedRange(1)
x2 = .Column
y2 = .Row
End With

'korygowanie położenia komórek najdalszej i "najbliższej"
For Each kom In rg
With kom
If Not .Value = Empty Then
If Not .EntireRow.Hidden Then
If x1 > .Column Then x1 = .Column
If y1 > .Row Then y1 = .Row
If x2 < .Column Then x2 = .Column
If y2 < .Row Then y2 = .Row
End If
End If
End With
Next

Set R_min_range = ws.Range(Cells(y1, x1), Cells(y2, x2))
Selection.Select

R_min_range_Exit:
On Error GoTo 0
'Selection.Select
Exit Function

R_min_range_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & _
") in procedure R_min_range"
End Function

J_B · Wysłany: 08-12-2013, 09:44

Witam
Na FB napisałeś

Oskar Shon (bez pustych wierszy czy kolumn w których brak danych). Nie powinna zwrócić obszaru wychodzącego poza Selection.

funkcja Artika zwraca puste kolumny i wiersze
w załączniku
wiersz 8-9 kolumna Ak-AL

funkcja 'Rycho zwraca puste wiersze
w załączniku wiersz 8-9

Oskar Shon Może być nieciągły (mile widziane takie rozwiązanie), jednakże funkcja powinna zwrócić (jednowymiarowy) ciągły a zarazem minimalny, zawierający wszystkie niepuste komórki.

Jeżeli nieciągły to może to co ja naskrobałem w załączniku

TestKonkurs.rar

Pobierz Plik ściągnięto 309 raz(y) 153.9 KB

Quasi · Wysłany: 08-12-2013, 10:22

OShon, wrzuć wszystkie pliki na serwer i daj linka :-)

Wormsek · Wysłany: 08-12-2013, 14:57

Temat już otwieram, jakby ktoś chciał coś dodać, albo coś prócz modków ;-)

.

A co do testów, to przyznaje, że zapomniałem o całym arkuszu, bądź kolumnach ;-)

.

OShon · Wysłany: 08-12-2013, 18:20

Quasi · Wysłany: 08-12-2013, 22:06

OShon, a sprawdzałeś jeszcze funkcje w sytuacji gdy pierwsza i ostatnia komórka Selection są niepuste? Tutaj też mogą wyjść ciekawe rzeczy.

Od siebie dodam jeszcze, że specjalnie napisałem funkcję, która zwraca w wyniku String zamiast Range, z tego względu, że można ją wykorzystać bezpośrednio w komórce arkusza. W ogóle funkcje nie powinny zwracać w wyniku obiektów, tylko wartości. Podobna sprawa jest z argumentami funkcji. Ale w tym przypadku w konkursie bylo zaznaczone, że funkcja ma działać tylko z poziomu VBA więc jest OK :-)

.

EDIT:
Oprócz pojedynczej pustej komórki, warto też sprawdzić zakres np. "A1:Z500000" składający się z samych niepustych komórek.

Artik · Wersja: Win Office 365 **Pomógł:** 3133 razy Posty: 10378

Przyznam się, że do konkursu się za bardzo nie przyłożyłem. Rozwiązanie oparłem na funkcji, którą wcześniej napisałem i na forum już publikowałem kilka miesięcy temu. Natomiast mając teraz porównanie mojego rozwiązania z kodem Rycha, widzę jak wolne potrafi być SpecialCells.

J_B · Wysłany: 09-12-2013, 18:29

Quasi · Wysłany: 09-12-2013, 21:00

Artik · Wersja: Win Office 365 **Pomógł:** 3133 razy Posty: 10378

Wormsek · Wysłany: 10-12-2013, 08:19

Hej, aż z ciekawości też wywołałem na 2010 i mam to samo co Artik. Ale na wirtualce odpaliłem na 2003 i mam ten sam wynik co Janusz. :shock:

Marecki · Wysłany: 10-12-2013, 08:31

A ja mam pytanie do J_B.
Dlaczego tak dziwnie określasz zakres:

Kod:

Range("A3:U" & w & "")

Czyż to nie to samo:

Kod:

Range("A3:U" & w)

?
A wracając do funkcji to u mnie na 2010 też jest OK.

Wormsek · Wysłany: 10-12-2013, 08:33

EDIT:
Art, ustawiłem watcha na zmiennej maxCol , aby się zatrzymał po zmianie tej wartości. Po zatrzymaniu, zmienna ma wartość od razu 23, czyli kolumna W.

Patrząc wcześniej, to w tym momencie już przyjmuje adres A3:W2000

Kod:

Set rng = Intersect(.Cells, _
.SpecialCells(xlCellTypeConstants))

A więc pytanie, czy czasami SpecialCells nie mają jakichś ograniczeń albo coś?

Dodatkowo jeszcze jako ciekawostka:
Wyłączyłem resume nexta i na intersecie z formułami mi się wysypał, bo ich nie widział. Więc działa dobrze, z widocznymi też zadziałał dobrze, bo wszystkie przyjął. Czyli te stałe jakoś brużdżą.

Wormsek · Wysłany: 10-12-2013, 08:42

Dobra, chyba już wiem.

Korzystając z wiedzy mistrza ;-)

http://www.rondebruin.nl/win/s4/win003.htm

Quasi · Wysłany: 10-12-2013, 08:57

Ograniczenie 8192 zakresów nieciągłych zostało zniesione dopiero w wersji Ex2010. W Ex2007 ten problem też występuje, dlatego IMO użycie SpecialCells nie jest dobrą opcją jeżeli w funkcji nie sprawdzamy wersji Excela :-)

.