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: Artik
28-02-2019, 00:12
makro wyszukujące najczęstsze rekordy
Autor Wiadomość
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 27-02-2019, 13:04   makro wyszukujące najczęstsze rekordy

Cześć,
potrzebuje pomocy w napisaniu makro które:
- wypisze 5 najczęściej występujących rekordów, zaczynając od najczęstrzego
- w nastepnej kolumnie policzy ile razy wystąpiły
- policzy ilość rekordów po usunięciu duplikatów

ps. numery mogą być dodawane a ich liczba może wzrastć nawet do 50 tys.

dane w arkusz1 tabela w arkusz2.
załanczam plik, dzięki

makro.xlsx
Pobierz Plik ściągnięto 32 raz(y) 16.3 KB

ID posta: 363350 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2119 razy
Posty: 7012
Wysłany: 01-03-2019, 20:18   

Nie jest to makro - zrobiłem to za pomocą Power Query.

makro(1).xlsx
Pobierz Plik ściągnięto 27 raz(y) 23.51 KB

_________________
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: 363524 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 02-03-2019, 20:40   

dzięki Marecki za chęci, niestety Power Query nie używam potrzebuję skrypt albo chociaż formuły.
jeśli nie da się tego zrobić w makro to, może tylko część zadania.

- aby skrypt skopiował wszystkie rekordy z kolumny C :C do innego arkusza do kolumny np D2, ale bez duplikatów, czyli w tym przypadku 211 wierszy, mógłbym sam nagrać makro skopiować kolumnę i usunąć duplikaty, tylko w przypadku 100tys wierszy na wolnym procku trwa to kilka minut, może skrypt vba będzie szybszy

ps. mógłbyś też zerknąć do tematu ogólne? pomogłeś mi ze Google Script- wypisujące aktualnego użytkownika ale mam z tym skryptem jeszcze jeden problem wklejając serie danych nie wypisują się dane w każdym wierszu tylko w pierwszym
dzięki
ID posta: 363546 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2119 razy
Posty: 7012
Wysłany: 02-03-2019, 22:21   

ezq napisał/a:
mógłbym sam nagrać makro skopiowac kolumne i usunąć duplikaty , tylko w przypadku 100tys wierszy na wolnym procku trwa to kilka minut, moze skrypt vba bedzie szybszy
Nie rozumiem, makro a skrypt VBA to to samo :roll:
Testuj takie makro:
Kod:
Sub Test()
    Dim sh_out         As Worksheet
    Dim OstW           As Long
    Dim rng            As Range
    Dim ile_nr         As Long

    Application.ScreenUpdating = False

    With Sheets("Arkusz1")
        OstW = .Cells(Rows.Count, 3).End(xlUp).Row
        Set sh_out = Sheets.Add
        Columns("A:A").NumberFormat = "@"
        Range("A1:A" & OstW).Value = .Range(.Cells(1, 3), .Cells(OstW, 3)).Value
    End With

    Set rng = sh_out.Range("A2:A" & OstW)
    sh_out.Range("B1").Value = "Licz"
    rng.Offset(, 1).Formula = "=COUNTIF($A$2:$A$" & OstW & ",A2)"

    With sh_out.Range("$A$1:$B" & OstW)
        .Value = .Value
    End With

    sh_out.Sort.SortFields.Clear
    sh_out.Sort.SortFields.Add2 Key:=Range("B1"), _
                                SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    With sh_out.Sort
        .SetRange Range("A2:B" & OstW)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    sh_out.Range("$A$1:$B" & OstW).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes

    With Sheets("Arkusz2")
        .Range("C3:C7").NumberFormat = "@"
        .Range("E3").Value = sh_out.Cells(Rows.Count, 3).End(xlUp).Row
        .Range("C3:D7").Value = sh_out.Range("A2:B6").Value
    End With

    Application.DisplayAlerts = False
    sh_out.Delete
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True

End Sub


ezq napisał/a:
wklejając serie danych nie wypisuja sie dane w każdym wierszu tylko w pierwszym
Zerknę do tego, ale dopiero około czwartku.

I proszę pisać po polsku - używając "ogonków", bo widzę że możesz.
_________________
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: 363550 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1198 razy
Posty: 3548
Wysłany: 02-03-2019, 23:36   

Przetestuj mój kod. Uwzględnia on wszystkie dane w kol. C arkusza1.
Kod:
Sub MaxDuplikaty()
    Dim i As Long
    Dim d As Object, lst As Object
    Dim a(), k, v
    Dim ms As String
   
    Set d = CreateObject("scripting.dictionary")
    Set lst = CreateObject("System.Collections.ArrayList")
    With Sheets("Arkusz1")
        a = .Range("C2:C" & .Cells(Rows.Count, "C").End(3).Row).Value
    End With
    For i = 1 To UBound(a)
        ms = a(i, 1)
        If Len(ms) > 0 Then d(ms) = d(ms) + 1
    Next
    For Each k In d.Keys
        lst.Add d.Item(k) & "_" & k
    Next
    lst.Sort
    lst.Reverse
    Application.ScreenUpdating = False
    With Sheets("Arkusz2")
        .[C2].CurrentRegion.Offset(1, 1).ClearContents
        .[E3] = lst.Count
        For i = 0 To 4
            v = Split(lst.Item(i), "_")
            .Range("C" & .Cells(Rows.Count, "C").End(3).Row)(2).Resize(1, 2) = Array(v(1), v(0))
        Next
    End With
    Set d = Nothing
    Set lst = Nothing
End Sub
Pozdrawiam.
ID posta: 363556 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1234 razy
Posty: 4296
Wysłany: 03-03-2019, 00:11   

Marecki napisał/a:

Testuj takie makro:
Kod:
Sub Test()
    ...
        .Range("E3").Value = sh_out.Cells(Rows.Count, 3).End(xlUp).Row
       ...
End Sub




Wynik w E3 o 2 za duży ;-)
ID posta: 363558 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 03-03-2019, 21:23   

dzięki kuma, o to chodziło
ID posta: 363586 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 07-03-2019, 20:16   

już myślałem że wszystko jest ok ale niestety kod kuma działa tylko przy max. 30 wierszy , powyżej wykazuje błędne dane , załączam plik

ps. czy byłaby możliwość dodania dwóch warunków do liczenia ?
jeżeli w kolumnie E jest "TAK" a w kolumnie H jest data ">=" 2019=03=05 11:22

makro.xlsm
Pobierz Plik ściągnięto 16 raz(y) 32.14 KB

ID posta: 363809 Skopiuj do schowka
 
 
apollo
ExcelSpec


Pomógł: 1234 razy
Posty: 4296
Wysłany: 07-03-2019, 21:22   

ezq napisał/a:
już myślałem że wszystko jest ok ale niestety kod kuma działa tylko przy max. 30 wierszy , powyżej wykazuje błędne dane , załączam plik

ps. czy byłaby możliwość dodania dwóch warunków do liczenia ?
jeżeli w kolumnie E jest "TAK" a w kolumnie H jest data ">=" 2019=03=05 11:22

Czyli jak? Chcesz 2 wersje, jedna bez żadnych warunków i druga z 2 warunkami?
ID posta: 363815 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 07-03-2019, 21:31   

oczywiście najlepsza byłaby wersja z warunkami
ID posta: 363816 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1198 razy
Posty: 3548
Wysłany: 07-03-2019, 23:12   

ezq, co to znaczy, że wykazuje błędne dane?
ezq napisał/a:
...kod kuma działa tylko przy max. 30 wierszy , powyżej wykazuje błędne dane...
Przetestuj kod z warunkami. Myślę, że o to chodziło.
Kod:
Sub MaxDuplikaty_kuma()
    Dim i As Long
    Dim d As Object, lst As Object
    Dim a(), k, v
    Dim ms As String
    Dim dcz
       
    dcz = DateValue("2019-03-05") + TimeValue("11:22")
    Set d = CreateObject("scripting.dictionary")
    Set lst = CreateObject("System.Collections.ArrayList")
    With Sheets("Arkusz1")
        a = .Range("C2:H" & .Cells(Rows.Count, "C").End(3).Row).Value
    End With
    For i = 1 To UBound(a)
        ms = a(i, 1)
        If Len(ms) > 0 And UCase(a(i, 3)) = "TAK" And a(i, 6) >= dcz Then d(ms) = d(ms) + 1
    Next
    For Each k In d.keys
        lst.Add Format(d.Item(k), "00000") & "_" & k
    Next
    lst.Sort
    lst.Reverse
    Application.ScreenUpdating = False
    With Sheets("Arkusz2")
        .[C2].CurrentRegion.Offset(1, 1).ClearContents
        .[E3] = lst.Count
        For i = 0 To 4
            v = Split(lst.Item(i), "_")
            .Range("C" & .Cells(Rows.Count, "C").End(3).Row)(2).Resize(1, 2) = Array(v(1), v(0))
        Next
    End With
    Set d = Nothing
    Set lst = Nothing
End Sub
Pozdrawiam.
ID posta: 363820 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 08-03-2019, 00:11   

tzn. że wyniki były błędne, załaczyłem plik.

ale przetestowałem ten ostatni kod i wygląda dobrze, jedyny minus to taki ,że nie może być żadnego wpisu poniżej tabeli w kolumnie c bo inaczej dane wpisuje w innym miejscu ale to nie problem.
w weekend więcej potestuje.
wielkie dzięki kuma
ID posta: 363823 Skopiuj do schowka
 
 
ezq
Starszy Forumowicz


Posty: 41
Wysłany: 08-03-2019, 20:57   

testowałem dzisiaj i nie znalazłem problemów ale miałbym jeszcze małą proźbę , próbowałem sam to zmienić ale jestem za cienki bolek :(, chciałbym aby ten drugi warunek (w kolumnie H jest data ">" 2019=03=05 11:22) zmienić na jeżeli arkusz1 kolumna H jest ">=" w komórce arkusz2!a1 w której jest data, a więc nie na stałe ustalona w kodzie tylko porównywana z komórką. trochę zagmatwałem ale mam nadzieje że zrozumiesz, załączam plik

makro.xlsm
Pobierz Plik ściągnięto 23 raz(y) 32.53 KB

ID posta: 363869 Skopiuj do schowka
 
 
kuma 
Excel Expert


Pomógł: 1198 razy
Posty: 3548
Wysłany: 08-03-2019, 21:55   

Z mojej strony poprawka dopiero we wtorek.
Pogodnego weekendu.
Pozdrawiam.
ID posta: 363871 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2119 razy
Posty: 7012
Wysłany: 09-03-2019, 10:12   

Zamień
Kod:
dcz = DateValue("2019-03-05") + TimeValue("11:22")
na
Kod:
dcz = Sheets("Arkusz2").Range("A1").Value
_________________
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: 363878 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