Excel Forum - Porady, Pomoc,  Excel Help, Excel FAQ Strona Główna
 FAQ  RegulaminRegulamin  Szukaj   Użytkownicy   Grupy   Rejestracja   Profil   Twoje wiadomości   Zaloguj 


Poprzedni temat «» Następny temat
Przesunięty przez: bodek
06-07-2014, 20:50
Konkurs Mikołajowy
Autor Wiadomość
OShon 
Excel Expert



Zaproszone osoby: 398
Wersja: Win Office 365
Pomógł: 1638 razy
Posty: 8386
  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
  1. Patronus
  2. bizzy_17
  3. incognito

Kat Modkowa
  1. Artik
  2. TKuchta1
  3. mkkk23
  4. Worm
  5. Rycho
  6. Bodek
  7. 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
_________________
Oskar Shon - MVP Office System/Development 11/21, 3xMCC, 4/9/22 TechNet
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA | GL Excel VBA
Dodatki do Office VBATools.pl, aktualne promocje, darmowe artykuły i literatura
ID posta: 211497 Skopiuj do schowka
 
 
J_B 
Excel Expert


Wersja: Win Office 2016
Pomógł: 541 razy
Posty: 1339
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

ID posta: 212452 Skopiuj do schowka
 
 
Quasi 
Excel Expert


Wersja: Win Office 365
Pomógł: 142 razy
Posty: 1103
Wysłany: 08-12-2013, 10:22   

OShon, wrzuć wszystkie pliki na serwer i daj linka :-)
_________________
http://www.swiatexcela.pl - blog nie tylko dla programistów VBA
ID posta: 212454 Skopiuj do schowka
 
 
Wormsek 



Zaproszone osoby: 2
Wersja: Win Office 2016
Pomógł: 919 razy
Posty: 5281
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 ;-) .
_________________
Pozdro
Worm

FAQ - Najczęściej zadawane pytania.
JAK KORZYSTAĆ Z SZUKAJKI
Słownik funkcji

Znajdź nas na Facebook'u

A może fajny dodatek do excela?
ID posta: 212479 Skopiuj do schowka
 
 
OShon 
Excel Expert



Zaproszone osoby: 398
Wersja: Win Office 365
Pomógł: 1638 razy
Posty: 8386
Wysłany: 08-12-2013, 18:20   

J_B napisał/a:
(bez pustych wierszy czy kolumn w których brak danych). Nie powinna zwrócić obszaru wychodzącego poza Selection.

Chodziło o to że o ile zaznaczony obszar (selection) nie posiada danych to wynikiem funkcji ma być ten obszar, a jeśli w tym obszarze są jakieś dane to zakres ma być jednolitym minimalnym obszarem (jak to quasi ładnie sformułował usedrange dla selection).

Quasi napisał/a:
OShon, wrzuć wszystkie pliki na serwer i daj linka :-)

ok dziś w nocy, albo jutro wsadzę jeden pliczek, ze wszystkimi funkcjami aby można było sobie wybrać zawodnika i je przećwiczyć na danym zakresie.
_________________
Oskar Shon - MVP Office System/Development 11/21, 3xMCC, 4/9/22 TechNet
Forum moderator: Outlook.pl | ExcelForum.pl | MSDN dział VBA | GL Excel VBA
Dodatki do Office VBATools.pl, aktualne promocje, darmowe artykuły i literatura
ID posta: 212490 Skopiuj do schowka
 
 
Quasi 
Excel Expert


Wersja: Win Office 365
Pomógł: 142 razy
Posty: 1103
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.
_________________
http://www.swiatexcela.pl - blog nie tylko dla programistów VBA
ID posta: 212531 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3133 razy
Posty: 10378
Wysłany: 09-12-2013, 02:22   

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 napisał/a:
funkcja Artika zwraca puste kolumny i wiersze
w załączniku
wiersz 8-9 kolumna Ak-AL
Sprawa wierszy 8-9 myślę, że się już wyjaśniła. Ale kolumn? Janusz, ty to na Calc-u uruchamiałeś. ;-) Twój test mojego rozwiązania raczej potwierdza, że puste kolumny (AK:AL) nie wchodzą do zakresu wynikowego. :-)

Artik
ID posta: 212551 Skopiuj do schowka
 
 
J_B 
Excel Expert


Wersja: Win Office 2016
Pomógł: 541 razy
Posty: 1339
Wysłany: 09-12-2013, 18:29   

Artik napisał/a:
Twój test mojego rozwiązania raczej potwierdza, że puste kolumny (AK:AL) nie wchodzą do zakresu wynikowego


To ja tu już nic nie kumam ( bo pewnie że żabą nie jestem)
i żeby nie było że sie czepiam ;-)

Wywołaj swoją funkcje tym makrem
1 dla w=200
2 dla w=2000

Kod:


Sub TestArtik()
    Dim w As Long, x As Long
    Dim Kom As Range

    Sheets.Add After:=Sheets(Sheets.Count)
    Cells.ColumnWidth = 2.5
    w = 200 '2000
    x = 1

    For Each Kom In Range("A3:U" & w & "")
        If x Mod 2 = 0 Then
            Kom = "x"
        End If
        x = x + 1
    Next
    MinRng(Range("A3:W" & w & "")).Interior.Color = vbYellow

End Sub


u mnie w wyniku dla 2000 wierszy otrzymuję 2 kolumny więcej
ID posta: 212554 Skopiuj do schowka
 
 
Quasi 
Excel Expert


Wersja: Win Office 365
Pomógł: 142 razy
Posty: 1103
Wysłany: 09-12-2013, 21:00   

OShon napisał/a:
Quasi napisał/a:
OShon, wrzuć wszystkie pliki na serwer i daj linka :-)
ok dziś w nocy, albo jutro wsadzę jeden pliczek, ze wszystkimi funkcjami aby można było sobie wybrać zawodnika i je przećwiczyć na danym zakresie.


Czekamy :clap
_________________
http://www.swiatexcela.pl - blog nie tylko dla programistów VBA
ID posta: 212571 Skopiuj do schowka
 
 
Artik 



Wersja: Win Office 365
Pomógł: 3133 razy
Posty: 10378
Wysłany: 09-12-2013, 23:05   

J_B napisał/a:
Wywołaj swoją funkcje tym makrem
1 dla w=200
2 dla w=2000
Wywołałem (XL 2010)
Jednak używasz Calc-a. ;-)
W obu przypadkach zakresy kończą się u mnie na kolumnie U. Nie pozostaje chyba nic innego jak krokowo przeanalizować dlaczego tak się dzieje u Ciebie.

Artik
ID posta: 212580 Skopiuj do schowka
 
 
Wormsek 



Zaproszone osoby: 2
Wersja: Win Office 2016
Pomógł: 919 razy
Posty: 5281
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:
_________________
Pozdro
Worm

FAQ - Najczęściej zadawane pytania.
JAK KORZYSTAĆ Z SZUKAJKI
Słownik funkcji

Znajdź nas na Facebook'u

A może fajny dodatek do excela?
ID posta: 212584 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2521 razy
Posty: 8407
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.
_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 212586 Skopiuj do schowka
 
 
Wormsek 



Zaproszone osoby: 2
Wersja: Win Office 2016
Pomógł: 919 razy
Posty: 5281
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żą.
_________________
Pozdro
Worm

FAQ - Najczęściej zadawane pytania.
JAK KORZYSTAĆ Z SZUKAJKI
Słownik funkcji

Znajdź nas na Facebook'u

A może fajny dodatek do excela?
ID posta: 212587 Skopiuj do schowka
 
 
Wormsek 



Zaproszone osoby: 2
Wersja: Win Office 2016
Pomógł: 919 razy
Posty: 5281
Wysłany: 10-12-2013, 08:42   

Dobra, chyba już wiem.

Korzystając z wiedzy mistrza ;-)
http://www.rondebruin.nl/win/s4/win003.htm
Ron napisał/a:
The only problem is that there is a limit of 8192 areas that it can handle.
http://support.microsoft....kb;en-us;832293

Janusz wypełnia kodem dokładnie 20979 komórek, czyli co daje nam 20979 nieciągłych zakresików dla SpecialCellsów, dlatego się wysypuje, a na 2010 działa.
_________________
Pozdro
Worm

FAQ - Najczęściej zadawane pytania.
JAK KORZYSTAĆ Z SZUKAJKI
Słownik funkcji

Znajdź nas na Facebook'u

A może fajny dodatek do excela?
ID posta: 212590 Skopiuj do schowka
 
 
Quasi 
Excel Expert


Wersja: Win Office 365
Pomógł: 142 razy
Posty: 1103
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 :-) .
_________________
http://www.swiatexcela.pl - blog nie tylko dla programistów VBA
ID posta: 212593 Skopiuj do schowka
 
 
Wyświetl posty z ostatnich:   
Odpowiedz do tematu
Nie możesz pisać nowych tematów
Nie możesz odpowiadać w tematach
Nie możesz zmieniać swoich postów
Nie możesz usuwać swoich postów
Nie możesz głosować w ankietach
Nie możesz załączać plików na tym forum
Możesz ściągać załączniki na tym forum
Dodaj temat do Ulubionych
Wersja do druku

Skocz do:  

Powered by phpBB modified by Przemo © 2003 phpBB Group
Theme xandgreen created by spleen& Programosy modified v0.3 by warna
Opieka techniczna www.marketingNET.pl

Archiwum

Strona używa plików cookies.

Kliknij tutaj, żeby dowiedzieć się jaki jest cel używania cookies oraz jak zmienić ustawienia cookie w przeglądarce.
Korzystając ze strony użytkownik wyraża zgodę na używanie plików cookies, zgodnie z bieżącymi ustawieniami przeglądarki.
Sprawdź, w jaki sposób przetwarzamy dane osobowe