Elektroda.pl
Elektroda.pl
X

Search our partners

Find the latest content on electronic components. Datasheets.com
Elektroda.pl
Please add exception to AdBlock for elektroda.pl.
If you watch the ads, you support portal and users.

Excel VBA - wyszukiwanie ilości wierszy zależnych od kilku warunków

dj_rey 04 Feb 2017 11:14 882 13
  • #1
    dj_rey
    Level 4  
    Witam, byłbym wdzięczny za pomoc. Potrzebuję makro, które pomogło by w poniższym opisie.
    W Arkusz1 mam dane dotyczące kilku firm i teraz potrzebowałbym, aby zliczało mi ilość wierszy dla danej firmy do Arkusz2 z pominięciem tych, gdzie w kolumnie J jest "OK" i z podziałem na dane z kolumny A
    Przykład:
    Firma Firma_1 z kolumny C ma w totalu 19 wierszy
    6 wierszy z kodem 123 z kolumny A
    5 z kodem 235 z kolumny A - minus 1, gdyż jeden wiersz ma OK w kolumnie J czyli końcowy wynik wierszy to 4
    8 z kodem 450 z kolumny A - minus 4, gdyż jeden wiersz ma OK w kolumnie J czyli finalnie wierszy 5
    itd.
    Teraz aby ilości wierszy kopiowało do Arkusz2 (wpisałem tam ręcznie poprawne wyniki)
    Zaznaczyłem każdy podział firmy różnymi kolorami, aby ułatwić tłumaczenie.

    Dodatkowo jeśli jakaś firma z przypisanym kodem z kolumny A ma wszystkie wiersze zaznaczone OK, to aby usuwało ją automatycznie z listy w Arkusz2
    Przykład: Firma_3 z kodem 255 ma dwa wiersze, ale oba mają OK w kolumnie J, więc powinno je automatycznie usunąć z listy, a dane znajdujące się poniżej usuniętej firmy powinno automatycznie przesunąć jeden wiersz do góry
    OK w kolumnie J będzie przeze mnie dopisywane w zależności od potrzeb, więc po jakimś czasie lista w Arkusz2 powinna być pusta.
  • Helpful post
    #2
    JRV
    VBA, Excel specialist
    dj_rey wrote:
    firma z przypisanym kodem z kolumny A
    kod_2 nie ma znaczenia?

    Dodano po 43 [minuty]:

    Code: vb
    Log in, to see the code
  • #3
    dj_rey
    Level 4  
    Dzięki, nie, kod_2 nie ma znaczenia
    Przydałoby się jeszcze obramowanie, które znikało by razem z kurczącą się listą w Arkusz2 :)
  • Helpful post
    #4
    JRV
    VBA, Excel specialist
    dodaj przed End Sub
    Code: vb
    Log in, to see the code
  • #6
    dj_rey
    Level 4  
    Jeszcze mam jedną prośbę, aby dodatkowo w kolumnie I od wiersza 2 wypisywało firmy, gdzie w Arkusz1 mają w całości zaznaczone OK w kolumnie J
    Przykład:
    w Arkusz1 Firma_2 ma trzy wiersze i jeśli przy każdym wierszu będzie w kolumnie J OK to wtedy wyświetla ją w Arkusz2 w komórce I2, przy kolejnej firmie będzie komórka I3 itd.
  • #7
    JRV
    VBA, Excel specialist
    dj_rey wrote:
    wypisywało firmy
    niezaleznie od kod_1? np firma_1 jak bedzie 19 OK?
  • #8
    dj_rey
    Level 4  
    Tak zgadza się Firma_1 będzie miała 19, a kod_1 jest nieważny w tym przypadku
  • #9
    JRV
    VBA, Excel specialist
    dodaj przed End Sub
    Code: vb
    Log in, to see the code
  • #10
    dj_rey
    Level 4  
    W tej linii While bs(rs, 3) <> "" wyskakuje błąd Run-time error '1004': Application-defined or object-defined error
  • #11
    JRV
    VBA, Excel specialist
    ten kod miel byc w koncu makro 'kokos', po
    Code: vb
    Log in, to see the code
  • #12
    dj_rey
    Level 4  
    No tak wstawiłem i ten błąd w tej linii wyskakuje
    Code:
    Sub kokos()
    
    Dim bs As Range, bd As Range, bt As Range
    Dim rs&, re&, rd&
    Set bs = Sheets(1).Range("A:J").Cells
    Set bd = Sheets(2).Range("A:D").Cells
    re = bd(Rows.Count, 1).End(xlUp).Row + 1
    Range(bd.Rows(2), bd.Rows(re)).Delete
    bs.Sort key1:=bs(1, 3), key2:=bs(1, 1), Header:=xlYes
    rs = 2: re = 2: rd = 2
    While bs(rs, 1) <> ""
        If bs(rs, 1) <> bs(rs + 1, 1) Or bs(rs, 3) <> bs(rs + 1, 3) Then
            Set bt = Range(bs.Rows(re), bs.Rows(rs)).Cells
            If bt.Rows.Count <> Application.CountA(bt.Columns(10)) Then
                bd(rd, 1) = bt(1, 1): bd(rd, 2) = bt(1, 6): bd(rd, 3) = bt(1, 3)
                bd(rd, 4) = bt.Rows.Count - Application.CountA(bt.Columns(10))
                rd = rd + 1
            End If
            re = rs + 1
        End If
        rs = rs + 1
    Wend
    With Sheets(2).UsedRange
        For re = 7 To 12
            .Borders(re).Weight = xlThin
        Next
    End With
    rs = 2: re = 2: rd = 2
    While bs(rs, 3) <> ""
        If bs(rs, 3) <> bs(rs + 1, 3) Then
            Set bt = Range(bs.Rows(re), bs.Rows(rs)).Cells
            If bt.Rows.Count = Application.CountA(bt.Columns(10)) Then
                Sheets(2).Range("I" & rd) = bs(1, 3)
                rd = rd + 1
            End If
            re = rs + 1
        End If
        rs = rs = 1
    Wend
    End Sub
  • Helpful post
    #13
    JRV
    VBA, Excel specialist
    Aj.... literowka
    rs = rs = 1
    rs= rs+1 ma byc
  • #14
    dj_rey
    Level 4  
    ok, tyko, że kod kopiuje mi nazwę z komórki C1 (firma), a mi chodziło, aby kopiował nazwę firmy przy której wszędzie jest OK (Firma_1, Firma_2, ...) lub inaczej, jeśli jakaś firma Arkusz2 zniknie w całości z komórek A : D, to aby się pojawiła raz w kolumnie I