Elektroda.pl
Elektroda.pl
X

Wyszukiwarki naszych partnerów

Wyszukaj w ofercie 200 tys. produktów TME
Kategoria: Kamery IP / Alarmy / Automatyka Bram
Montersi
Proszę, dodaj wyjątek elektroda.pl do Adblock.
Dzięki temu, że oglądasz reklamy, wspierasz portal i użytkowników.

[Excel] VBA makro - problem

jaro99 23 Wrz 2009 18:20 10222 21
  • #1 23 Wrz 2009 18:20
    jaro99
    Poziom 8  

    Witam, jestem początkujący w VBA i mam problem, otóż potrzebuję w pracy zrobić makro do excela wykonujące określone czynności. W załączniku dołączam plik excela z dwoma arkuszami, z których pierwszy to arkusz na którym chce pracować i robić obliczenia, a drugi to tabela z punktami. Dołączam również początkowy kod który udało mi się jak do tej pory napisać, a który nie jest doskonały...Większość jest pisana na podstawie problemów i rozwiązań zaproponowanych na forum elektrody :)
    - w kolumnie A są usługi, z których każda należy do jednej z 3 różnych grup POTS/DSL/inne
    - do każdej z tych grup może być przypisana każda z operacji w kolumnie F
    - każda taka operacja ma swoją wartość punktową, którą chciałbym zadeklarować na stałe(w arkuszu 2 jest tabela punktowa), z tym, że w każdej grupie mogą mieć inne wartości punktowe
    np. operacja "dystrybucja" w grupie POTS ma wartość 0,2 ,a w grupie DSL 0,3 itd.

    Chciałbym aby makro na podstawie każdego z wierszy sprawdzało w kolumnie A do jakiej grupy(POTS/DSL/inne) przynależy usługa(np PSTN,ISDN,etc.), następnie na podstawie kolumny F przypisywała za pomocą określonych wartości liczbę punktów dla danej operacji(np. "dystrybucja") w grupie, którą wcześniej sprawdziło. Te punkty niech wpisuje do kolumny wartości - H ,a na końcu niech liczy iloczyn ilości i tej wartości punktowej (kolumna H * I)

    W kodzie mojego makra kompilator nie chce mi przyjąć liczb zmiennoprzecinkowych - Float - jak można zadeklarować tablice, w której będą liczby typu 0,3 ; 0,4 ;etc.?

    Jak już wspomniałem przejrzałem już sporą część tematów o excelu i vba i proszę o udzielenie rad jak sobie poradzić z tym zadaniem. Z góry wszystkim dziękuję!

    poniżej wklejam jeszcze raz kod makra

    Code:

    Sub Macro1()
    'deklaracje tablic grup POTS,DSL,inne dopisać
    Dim POTS(1 To 7) As Float
     POTS(1) = 0,2
     POTS(2) = 0,3
    Dim DSL(1 To 7) As Float
     DSL(1) = 0,4
     DSL(2) = 0,5
    Dim inne(1 To 7) As Float
     inne(1) = 0,6
     inne(2) = 0,7
     
    wynik1 = POTS(1)
    wynik2 = POTS(2)
    wynik3 = DSL(1)
    wynik4 = DSL(2)
    wynik5 = inne(1)
    wynik6 = inne(2)
    'ilewierszy = Workbooks(a).Sheets(1).Range(a1).End(xlDown).Row ' sprawdzenie ilosci wierszy w bazowej tabeli
    ostatniWiersz = ThisWorkbook.ActiveSheet.Range(a1).End(xlDown).Row
    pierwszyWiersz = 2 'bo od drugiego wiersza
     
    For i = pierwszyWiersz To ostatniWiersz

        If ThisWorkbook.ActiveSheet.Range(A & i) = POTS Then
                'warunki i pkt na grupe POTS
                If ThisWorkbook.ActiveSheet.Range(F & i) = Dystrybucja Then
                   ThisWorkbook.ActiveSheet.Range(H & i) = wynik1  ThisWorkbook.ActiveSheet.Range(G & i)
                Else
                If ThisWorkbook.ActiveSheet.Range(F & i) = Anulowanie Then
                   ThisWorkbook.ActiveSheet.Range(H & i) = wynik2  ThisWorkbook.ActiveSheet.Range(G & i)
                End If
        Else
        If ThisWorkbook.ActiveSheet.Range(A & i) = DSL Then
                If ThisWorkbook.ActiveSheet.Range(F & i) = Dystrybucja Then
                   ThisWorkbook.ActiveSheet.Range(H & i) = wynik3  ThisWorkbook.ActiveSheet.Range(G & i)
                Else
                If ThisWorkbook.ActiveSheet.Range(F & i) = Anulowanie Then
                   ThisWorkbook.ActiveSheet.Range(H & i) = wynik4  ThisWorkbook.ActiveSheet.Range(G & i)
                End If
        Else
        If ThisWorkbook.ActiveSheet.Range(A & i) = inne Then
                If ThisWorkbook.ActiveSheet.Range(F & i) = Dystrybucja Then
                    ThisWorkbook.ActiveSheet.Range(H & i) = wynik5  ThisWorkbook.ActiveSheet.Range(G & i)
                Else
                If ThisWorkbook.ActiveSheet.Range(F & i) = Anulowanie Then
                    ThisWorkbook.ActiveSheet.Range(H & i) = wynik6  ThisWorkbook.ActiveSheet.Range(G & i)
                End If
        End If
    Next

    End Sub

  • Pomocny post
    #2 23 Wrz 2009 20:23
    adamas_nt
    Moderator Programowanie

    Tak na pierwszy rzut oka.

    1. Nie ma typu zmiennej "Float". Tablice deklarujesz zwykle jako "Variant" lub nie wpisujesz typu i VB przyjmie typ domyślny, czyli "Variant" wlaśnie.
    2. Liczby ułamkowe w VB zapisujemy stosując kropkę (0.2 a nie 0,2)
    3. Przypisanie wartości zmiennej "ostatniWiersz", Range("a1") brak cudzysłowu i wszędzie gdzie składasz stringi: Range("A" & i)
    4. Porównując łańcuch umieść go w cudzysłowie

    Code:
    If ThisWorkbook.ActiveSheet.Range("A" & i) = "POTS" Then 

    5 i 6. Gałąź If-Else musi być zakończona znacznikiem "End If". Stosując kilka poleceń umieść je w osobnych liniach lub rozdziel dwukropkiem
    Code:
    If Range("F" & i) = "Dystrybucja" Then
    
        Range("H" & i) = wynik1: Range ("G" & i) '???
    ElseIf Range("F" & i) = "Anulowanie" Then
        Range("H" & i) = wynik
        Range ("G" & i) '???
    End If

    7. A to nie wiem. Nic nie przypisujesz?
    Code:
    ThisWorkbook.ActiveSheet.Range (G & i)
    a może chcesz wymnożyć? (bez operatora ani rusz)
    Code:
    Range("H" & i) = wynik1 * Range ("G" & i)

    8. To "ThisWorkbook.ActiveSheet" można pominąć. Nieszkodliwa nadmiarowość...

    P.S. Gdyby wartości wpisane w kolumnie A w Arkusz1 były zgodne z nagłówkami w Arkusz2 (wiersz 1 od B w prawo) strasznie ułatwiłoby to sprawę. Wystarczyłyby nawet zwykłe funkcje Excela. (JEŻELI, INDEKS, PODA.POZYCJĘ)
    W innym przypadku można jako trzeci warunek użyć
    Code:
    ElseIf Range("A" & i) <> "POTS" And Range("A" & i) <> "DSL" Then
    Problem w tym, że i tak nic z tej kolumny nie pasuje...

  • #3 24 Wrz 2009 14:59
    jaro99
    Poziom 8  

    to mój aktualny kod:

    Code:

    Sub Macro1()
    'deklaracje tablic grup POTS,DSL,inne dopisać
    Dim POTS(1 To 2) As Variant
     POTS(1) = "0.2"
     POTS(2) = "0.3"
    Dim DSL(1 To 2) As Variant
     DSL(1) = "0.4"
     DSL(2) = "0.5"
    Dim inne(1 To 2) As Variant
     inne(1) = "0.6"
     inne(2) = "0.7"

    ' sprawdzenie ilosci wierszy w bazowej tabeli
    ostatniWiersz = ThisWorkbook.ActiveSheet.Range("A1").End(xlDown).Row
    pierwszyWiersz = 2 'bo od drugiego wiersza
     
    For i = pierwszyWiersz To ostatniWiersz

        If ThisWorkbook.ActiveSheet.Range("A" & i) = "POTS" Then
                'warunki i pkt na grupe POTS
                If ThisWorkbook.ActiveSheet.Range("F" & i) = "Dystrybucja" Then
                    ThisWorkbook.ActiveSheet.Range("H" & i) = POTS(1) * ThisWorkbook.ActiveSheet.Range("G" & i).Value
                Else
                If ThisWorkbook.ActiveSheet.Range("F" & i) = "Anulowanie" Then
                    ThisWorkbook.ActiveSheet.Range("H" & i) = POTS(2) * ThisWorkbook.ActiveSheet.Range("G" & i).Value
                Exit For
                End If
        End If
        End If
        If ThisWorkbook.ActiveSheet.Range("A" & i) = "DSL" Then
                If ThisWorkbook.ActiveSheet.Range("F" & i) = "Dystrybucja" Then
                    ThisWorkbook.ActiveSheet.Range("H" & i) = DSL(1) * ThisWorkbook.ActiveSheet.Range("G" & i).Value
                Else
                If ThisWorkbook.ActiveSheet.Range("F" & i) = "Anulowanie" Then
                    ThisWorkbook.ActiveSheet.Range("H" & i) = DSL(2) * ThisWorkbook.ActiveSheet.Range("G" & i).Value
                Exit For
                End If
         End If
         End If
         If ThisWorkbook.ActiveSheet.Range("A" & i) = "inne" Then
                If ThisWorkbook.ActiveSheet.Range("F" & i) = "Dystrybucja" Then
                    ThisWorkbook.ActiveSheet.Range("H" & i) = inne(1) * ThisWorkbook.ActiveSheet.Range("G" & i).Value
                Else
                If ThisWorkbook.ActiveSheet.Range("F" & i) = "Anulowanie" Then
                    ThisWorkbook.ActiveSheet.Range("H" & i) = inne(2) * ThisWorkbook.ActiveSheet.Range("G" & i).Value
                Exit For
                 End If
         End If
         End If
       Next
    End Sub


    teraz otrzymuje błąd podczas kompliacji - " run time error '13' : Type mismatch" więc pomieszałem gdzieś typy zmiennych/danych, a nie potrafie tego znaleźć...

    czy mógłby ktoś sprawdzić czy mam dobrze pozamykane pętle If->End If oraz For->Next ? wcześniej kompliator się tego czepiał, ale chyba już powinno być ok.

    co do kodu, który wkleiłem wcześniej to nie wiem dlaczego ale zniknęły mi cudzysłowia i znaki mnożenia * dlatego tak dziwnie to wszystko wyglądało...

  • Pomocny post
    #4 24 Wrz 2009 18:07
    adamas_nt
    Moderator Programowanie

    Przypisujesz wartości tablicy jako łańcuchy (cudzysłowy) a nie liczby. Z tymi If-Else pewnie działa, ale jakoś tak zagmatwane... Polecenie opuszczenia pętli (Exit For) po mojemu jest niepotrzebne.

    Code:
    Sub Macro1()
    
    'deklaracje tablic grup POTS,DSL,inne dopisać
    Dim POTS(1 To 2) As Variant
     POTS(1) = 0.2
     POTS(2) = 0.3
    Dim DSL(1 To 2) As Variant
     DSL(1) = 0.4
     DSL(2) = 0.5
    Dim inne(1 To 2) As Variant
     inne(1) = 0.6
     inne(2) = 0.7

    ' sprawdzenie ilosci wierszy w bazowej tabeli
    ostatniWiersz = Range("A1").End(xlDown).Row
    pierwszyWiersz = 2 'bo od drugiego wiersza
     
    For i = pierwszyWiersz To ostatniWiersz

        If Range("A" & i) = "POTS" Then
            'warunki i pkt na grupe POTS
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = POTS(1) * Range("G" & i).Value
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = POTS(2) * Range("G" & i).Value
                'Exit For
            End If
        ElseIf Range("A" & i) = "DSL" Then
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = DSL(1) * Range("G" & i).Value
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = DSL(2) * Range("G" & i).Value
                'Exit For
            End If
        ElseIf Range("A" & i) = "inne" Then
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = inne(1) * Range("G" & i).Value
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = inne(2) * Range("G" & i).Value
                'Exit For
            End If
        End If
    Next
    End Sub

  • #5 24 Wrz 2009 18:22
    jaro99
    Poziom 8  

    dzięęęki !!!
    już wszystko działa :)
    teraz biore się za rozbudowę trochę :)

    dla zainteresowanych wklejam jeszcze kod po drobnej przeróbce - wyświetla wynik i wartość punktowa w oddzielnych komórkach. a poniżej plik z kodem

    Code:

    Sub Macro1()
    'deklaracje tablic grup POTS,DSL,inne dopisać
    Dim POTS(1 To 2) As Variant
     POTS(1) = 0.2
     POTS(2) = 0.3
    Dim DSL(1 To 2) As Variant
     DSL(1) = 0.4
     DSL(2) = 0.5
    Dim inne(1 To 2) As Variant
     inne(1) = 0.6
     inne(2) = 0.7

    ' sprawdzenie ilosci wierszy w bazowej tabeli
    ostatniWiersz = Range("A1").End(xlDown).Row
    pierwszyWiersz = 2 'bo od drugiego wiersza
     
    For i = pierwszyWiersz To ostatniWiersz

        If Range("A" & i) = "POTS" Then
            'warunki i pkt na grupe POTS
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = POTS(1)
                Range("I" & i) = POTS(1) * Range("G" & i).Value
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = POTS(2)
                Range("I" & i) = POTS(2) * Range("G" & i).Value
                'Exit For
            End If
        ElseIf Range("A" & i) = "DSL" Then
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = DSL(1)
                Range("I" & i) = DSL(1) * Range("G" & i).Value
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = DSL(2)
                Range("I" & i) = DSL(2) * Range("G" & i).Value
                'Exit For
            End If
         ElseIf Range("A" & i) = "inne" Then
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = inne(1)
                Range("I" & i) = inne(1) * Range("G" & i).Value
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = inne(2)
                Range("I" & i) = inne(2) * Range("G" & i).Value
                'Exit For
            End If
         End If
       Next
    End Sub

  • #6 28 Wrz 2009 18:15
    jaro99
    Poziom 8  

    na chwile obecną mam taki kod:

    Code:

    Sub Macro1()
    Dim POTS(1 To 2) As Variant
     POTS(1) = 0.2
     POTS(2) = 0.3
    Dim DSL(1 To 2) As Variant
     DSL(1) = 0.4
     DSL(2) = 0.5
    Dim inne(1 To 2) As Variant
     inne(1) = 0.6
     inne(2) = 0.7

    ' sprawdzenie ilosci wierszy w bazowej tabeli
    ostatniWiersz = Range("A1").End(xlDown).Row
    pierwszyWiersz = 2 'bo od drugiego wiersza
     
    For i = pierwszyWiersz To ostatniWiersz

        If Range("A" & i) = "POTS" Then
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = POTS(1)
                If IsNumeric(Range("G" & i).Value) Then
                Range("I" & i) = POTS(1) * Range("G" & i).Value
                End If
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = POTS(2)
                If IsNumeric(Range("G" & i).Value) Then
                Range("I" & i) = POTS(2) * Range("G" & i).Value
                End If
            End If
        ElseIf Range("A" & i) = "DSL" Then
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = DSL(1)
                If IsNumeric(Range("G" & i).Value) Then
                Range("I" & i) = DSL(1) * Range("G" & i).Value
                End If
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = DSL(2)
                If IsNumeric(Range("G" & i).Value) Then
                Range("I" & i) = DSL(2) * Range("G" & i).Value
                End If
            End If
         ElseIf Range("A" & i) = "inne" Then
            If Range("F" & i) = "Dystrybucja" Then
                Range("H" & i) = inne(1)
                If IsNumeric(Range("G" & i).Value) Then
                Range("I" & i) = inne(1) * Range("G" & i).Value
                End If
            ElseIf Range("F" & i) = "Anulowanie" Then
                Range("H" & i) = inne(2)
                If IsNumeric(Range("G" & i).Value) Then
                Range("I" & i) = inne(2) * Range("G" & i).Value
                End If
            End If
         End If
       Next
    End Sub

    w tej chwili makro wyświetla wynik i wartość punktowa w oddzielnych komórkach oraz jest zabezpieczone przed wpisywaniem w komórki znaków innych niż cyfry w miejscach gdzie spodziewane są liczby

    natomiast potrzebuję teraz aby moje makro, patrząc na Arkusz1 z Zeszytu7.xls z mojego pierwszego postu wykonywało dodatkowo taką funkcję:
    -sortowało/ustawiało operacje od każdego nazwiska jedno pod drugim, potem drugie nazwisko itd.
    -dla każdego konkretnego nazwiska sumowało wszystkie punkty z kolumny SUMA i wyświetlało w kolejnej kolumnie J - w wierszu który jest ostatnim dla tego nazwiska
    (próbowalem to wykonać przez pętle For...Each...In... ale miałem problem z tworzeniem obiektu,mieszaniem typów,etc. generealnie nie wiem o co chodzi z tym tworzeniem obiektu przez np. Set plik = cośtam i co to potem daje oraz jak to wykorzystać we wspomnianej pętli

    Proszę o jakieś podpowiedzi, z góry dzięki i pozdrawiam

  • Pomocny post
    #7 28 Wrz 2009 22:39
    adamas_nt
    Moderator Programowanie

    Poszukaj informacji na temat sortowania bąbelkowego. Tak się składa, że w VB litery i łańcuchy też można porównywać. "b">"a", "Alicja">"Ala" itd

    Musiałbyś kopiować dane ze wszystkich kolumn wiersza do tymczasowej tablicy, co pokazałeś że potrafisz już robić.

    Sumowanie najlepiej zrobić funkcją SUMA.JEŻELI. W VB Aplication.WorksheetFunction.SumIf(argumenty), wyszukując najpierw ostatniego wiersza z nazwiskiem (pętla For lub Do)

    Sugeruję taką kolejność: sortowanie, obliczenia (masz gotowe), podsumowania.

  • #8 29 Wrz 2009 21:24
    jaro99
    Poziom 8  

    Code:

    Sub Marko4()
    Dim Osoby As Object
    ostatniWiersz = Range("I1").End(xlDown).Row
    pierwszyWiersz = 2
    nazwisko = InputBox ("Podaj nazwisko osoby do zliczenia punktów")

    For i = pierwszyWiersz To ostatniWiersz
             Set Osoby = Range("B" & I)
             For Each nazwisko In Osoby
             If IsNumeric(Range("I" & i).Value) Then
                   suma_pkt = "=Sum(I1:I8)"
                   Range("J" & I).Formula = suma_pkt
             End If
             Next nazwisko
    Next
    End Sub

    -powyższy kod zlicza mi punkty z wskazanego zakresu ale nie potrafię go "zmusić" przede wszystkim do tego żeby zliczał mi taką ilość jaka jest ilość wierszy w kolumnie "I" z punktami, tzn gdy wpisuje suma_pkt = "=Sum(Range("I" & I))" to wyskakuje mi syntax error i różne moje kombinacje nie rozwiązują problemu

    - dodatkowo (nie wiem jakiej składni użyć) aby wyświetlać tą sumę w konkretnej komórce tzn. wiem że muszę użyć czegoś na kształt ostatnieNazwiskoWWierszu = Range("B1").End(xlDown).Row??? jak to zrobić?

    -sortowanie zrobie na końcu , na razie znalazłem na elektrodzie takie materiały na to:
    Link
    Link

  • Pomocny post
    #9 29 Wrz 2009 22:45
    adamas_nt
    Moderator Programowanie

    Popełniłeś dwa błędy w jednym wierszu... Do wyboru

    Code:
    If IsNumeric((Cells(i, "I").Value)) = True Then
    
    If IsNumeric((Cells(i, 9).Value)) = True Then

    Natomiast wyszukanie ostatniego wiersza z nazwiskiem możesz zrobić w pętli przez porównanie. Np (dla wierszy od D2 w dół) taką
    Code:
    Sub petla()
    
    For i = 2 To Range("D2").End(xlDown).Row
        For j = i To Range("D2").End(xlDown).Row
            If Cells(j, 4) <> Cells(j + 1, 4) Then Exit For
        Next
        i = j
        MsgBox Cells(j, 4).Address & " " & Cells(j, 4).Value
    Next
    End Sub
    Przeanalizuj, dostosuj do swoich potrzeb.

    Edit 23:00 zmieniłem trochę. Siódemka się zakradła...
    Edit2
    jaro99 napisał:
    suma_pkt = "=Sum(Range("I" & I))" to wyskakuje mi syntax error
    adamas_nt napisał:
    W VB Aplication.WorksheetFunction.SumIf(argumenty)
    Sorry za brak "p".
    W związku z tym w naszej pętli zamiast MsgBox wystarczy podstawić
    Code:
    Cells(j, 10) = Application.WorksheetFunction.SumIf(Arg1, Arg2, Arg3)
    gdzie Arg1 to "badany" zakres, Arg2 komórka z podstawioną aktualną wartością zmiennej "j", Arg3 to zakres z punktami (w formacie liczbowym). Np
    Code:
    (Range("D:D"), Cells(j, 4), Range("G:G"))

  • #10 30 Wrz 2009 20:54
    jaro99
    Poziom 8  

    Sortowanie załatwiłem przez nagranie makra i skopiowanie tego co chciałem jak tutaj:

    Code:

    Range("A:I").Sort Key1:=Range("B2"), Order1:=xlAscending

    co do wyszukiwania ostatniego wiersza z nazwiskiem możesz zrobić w pętli przez porównanie. Np (dla wierszy od D2 w dół) taką jak poniżej, to nie wiem za bardzo jak to działa...a kombinowałem na wiele sposobów...rozumiem ta pętla że porównuje dwie komórki jedna pod drugą,ale nie wiem co daje ten wiersz z MsgBox? mógłbyś mi to przybliżyć?
    Code:

    Sub petla()
    For i = 2 To Range("D2").End(xlDown).Row
        For j = i To Range("D2").End(xlDown).Row
            If Cells(j, 4) <> Cells(j + 1, 4) Then Exit For
        Next
        i = j
        MsgBox Cells(j, 4).Address & " " & Cells(j, 4).Value
    Next
    End Sub

    chciałbym aby makro po sortowaniu i ustawieniu nazwisk pod sobą ,zsumowało punkty za operacje z każdego nazwiska i wpisało je w ostatnim wierszu w którym znajduje się to nazwisko, w kolumnie J , nie wiem jaki range dać w tej sumie :
    Code:
    Cells(j, 10) = Application.WorksheetFunction.SumIf(Arg1, Arg2, Arg3)

    tak żeby dotyczyło to tego wiersza z ostatnim nazwiskiem... jak to można zrobić?
    czy można to zrobić na kształt tego:
    Code:
    Range("I1").End(xlDown).Row 
    ??
    tylko dodać do range zmienną określającą ten wiersz?
    W pomocy VB editora znalazłem wyszukiwanie określonej zmiennej w arkuszu i próbowałem je dostosować do swojego przypadku:
    Code:

    'moje deklaracje :
    ost = Range("I1").End(xlDown).Row   <-tu cos kombinowalem z tym rangem zeby dało to ostatecznie wiersz z nazwiskiem, ale wciąż nie wiem jak to wpisać
    nazwisko = InputBox("podaj nazwisko")

    With Worksheets(1).Range("B:B")
         Set c = .Find(nazwisko, LookIn:=xlValues)
            If Not c Is Nothing Then
                 firstAddress = c.Address
                 Do
     'linia napisana przeze mnie ->>>>          sumka = sumka + c.Cells(i, "I").Value
                       Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
     'linia napisana przeze mnie ->>>>           Range("K" & ost).Value = sumka
           End If
    End With

    generalnie nie mogę przejść tego wyszukiwania wiersza z tym nazwiskiem -,-
    wiem jak zrobic zeby wpisywalo w konkretną komórkę ale mimo wszystko nie wiem jak to robić automatycznie...

  • Pomocny post
    #11 30 Wrz 2009 21:56
    adamas_nt
    Moderator Programowanie

    adamas_nt napisał:
    w naszej pętli zamiast MsgBox wystarczy podstawić

    Razem byłoby coś takiego
    Code:
    Sub petla()
    
    For i = 2 To Range("D2").End(xlDown).Row
        For j = i To Range("D2").End(xlDown).Row
            If Cells(j, 4) <> Cells(j + 1, 4) Then Exit For 'porownanie w kol D indeks 4
        Next
        i = j 'żeby nie od trzeciego (po pierwszym przebiegu i=3) tylko od wiersza j+1
        Cells(j, 10) = Application.WorksheetFunction.SumIf(Range("D:D"), Cells(j, 4), Range("G:G"))
    Next
    End Sub
    gdzie kolumna z nazwiskami to "D" a z punktami "G" koniecznie w formacie liczbowym.
    Działanie:
    Wewnętrzna pętla porównuje komórki w kolumnie z nazwiskami. Jeśli trafi na różne, następuje przerwanie działania (Exit For) i wyjście do zewnętrznej. W tym momencie zmienna "j" to numer wiersza, który nas interesuje. Następuje wywołanie funkcji SUMA.JEŻELI, zapisanie wyniku w kolumnie "J" (10) i pętla "leci" sobie dalej aż do następnej nierówności. I tak w kółko, jak to w pętli...

    Lub prościej (?)
    Code:
    Sub petla()
    
    For j = 2 To Range("D2").End(xlDown).Row
        If Cells(j, 4) <> Cells(j + 1, 4) Then Cells(j, 10) = _
        Application.WorksheetFunction.SumIf(Range("D:D"), Cells(j, 4), Range("G:G"))
    Next
    End Sub


    p.s. Nie wszystkie wersje akceptują zapis Range("A:A"). Należy wtedy dokładniej określić zakres. Np Range("A1:A65536") dla całej kolumny.

  • #12 01 Paź 2009 14:05
    jaro99
    Poziom 8  

    po poprawkach wygląda to tak:

    Code:

    Sub Macro1()
    'deklaracje tablic grup POTS,DSL,inne dopisać
    Dim POTS(1 To 2) As Variant
     POTS(1) = "0.2"
     POTS(2) = "0.3"
    Dim DSL(1 To 2) As Variant
     DSL(1) = "0.4"
     DSL(2) = "0.5"
    Dim inne(1 To 2) As Variant
     inne(1) = "0.6"
     inne(2) = "0.7"

    ' sprawdzenie ilosci wierszy w bazowej tabeli
    ostatniWiersz = ThisWorkbook.ActiveSheet.Range("A1").End(xlDown).Row
    pierwszyWiersz = 2 'bo od drugiego wiersza
     
    'sortowanie
        Range("A:I").Sort Key1:=Range("B2"), Order1:=xlAscending, Key2:=Range("A2"), _
        Order2:=xlAscending, Key3:=Range("F2"), Order3:=xlAscending, _
        Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal, DataOption2:=xlSortNormal, DataOption3:=xlSortNormal

    'obliczenia
    For i = pierwszyWiersz To ostatniWiersz
        If Range("A" & i) = "POTS" Then
                If Range("F" & i) = "Dystrybucja" Then
                    Range("H" & i) = POTS(1)
                    If IsNumeric(Range("G" & i).Value) Then
                    Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                    End If
                ElseIf Range("F" & i) = "Anulowanie" Then
                    Range("H" & i) = POTS(2)
                    If IsNumeric(Range("G" & i).Value) Then
                    Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                    End If
                End If
        ElseIf Range("A" & i) = "DSL" Then
                If Range("F" & i) = "Dystrybucja" Then
                    Range("H" & i) = DSL(1)
                    If IsNumeric(Range("G" & i).Value) Then
                    Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                    End If
                ElseIf Range("F" & i) = "Anulowanie" Then
                    Range("H" & i) = DSL(2)
                    If IsNumeric(Range("G" & i).Value) Then
                    Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                    End If
                End If
         ElseIf Range("A" & i) = "inne" Then
                If Range("F" & i) = "Dystrybucja" Then
                    Range("H" & i) = inne(1)
                    If IsNumeric(Range("G" & i).Value) Then
                    Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                    End If
                ElseIf Range("F" & i) = "Anulowanie" Then
                    Range("H" & i) = inne(2)
                    If IsNumeric(Range("G" & i).Value) Then
                    Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                    End If
                End If
         End If
    Next

    'sumowanie
    Sheets("Arkusz2").Cells(1, 1).Value = Sheets("Arkusz1").Cells(1, 2).Value 'etykieta kolumny
    Sheets("Arkusz2").Cells(1, 2).Value = Sheets("Arkusz1").Cells(1, 3).Value
    Sheets("Arkusz2").Cells(1, 3).Value = Sheets("Arkusz1").Cells(1, 4).Value
    Sheets("Arkusz2").Cells(1, 4).Value = Sheets("Arkusz1").Cells(1, 10).Value
    m = 1 'początkowe ustawienie licznika =1 ponieważ musimy zostawić miejsce na etykiety kolumn
    For k = 2 To Range("B2").End(xlDown).Row
        For j = k To Range("B2").End(xlDown).Row
            If Cells(j, 2) <> Cells(j + 1, 2) Then Exit For
        Next
        k = j
        Cells(j, 10) = Application.WorksheetFunction.SumIf(Range("B:B"), Cells(j, 2), Range("I:I"))
        Cells(j, 10).Interior.ColorIndex = 4
        Cells(j, 10).Borders.LineStyle = xlDouble
        'raport - przenoszenie danych na nowy arkusz
        m = m + 1 'licznik ilości wierszy do przeniesienia
        Sheets("Arkusz2").Cells(m, 1).Value = Sheets("Arkusz1").Cells(j, 2).Value 'wartość wpisywana do kolumny
        Sheets("Arkusz2").Cells(m, 2).Value = Sheets("Arkusz1").Cells(j, 3).Value
        Sheets("Arkusz2").Cells(m, 3).Value = Sheets("Arkusz1").Cells(j, 4).Value
        Sheets("Arkusz2").Cells(m, 4).Value = Sheets("Arkusz1").Cells(j, 10).Value
    Next
     
    End Sub

    działają wszystkie funkcje o które mi chodziło :)

    teraz będe tworzył podobne makro z dodaniem grupowania, przynależność do grupy ma być pobierana z innego arkusza - da się coś takiego zrobić standartową komendą .Group ? jak próbowałem rejestrowania makra to widziałem że excel ją wykorzystuje

  • Pomocny post
    #13 01 Paź 2009 18:33
    adamas_nt
    Moderator Programowanie

    jaro99 napisał:
    da się coś takiego zrobić standartową komendą .Group ? jak próbowałem rejestrowania makra to widziałem że excel ją wykorzystuje
    Tak, oczywiście musisz tylko podać zakres w wierszach lub kolumnach. Np
    Code:
    i = 1
    
    k = 3
    m = 5
    Range(Columns(i), Columns(k)).Columns.Group
    Range(Rows(i), Rows(m)).Rows.Group

  • #14 02 Paź 2009 13:58
    jaro99
    Poziom 8  

    teraz potrzebuję aby makro na podstawie danych z Arkusza2, w którym znajduje się tabela nazwisk i przynależności do grup odpowiednio grupowało wiersze z nazwiskami należącymi do odpowiednich grup np A,B,C,D ,obliczało konkretne wartości dla tych nazwisk - i to mam już gotowe i działające we wstępnym kodzie poniżej (do dopracowania)

    chciałbym jeszcze aby po pogrupowaniu grupy zostały posortowane tzn. od góry arkusza grupa A (czyli wszystkie wiersze z nazwiskami należącymi do tej grupy), potem grupa B, itd. - i tu pojawia się problem bo nie wiem jak to składniowo zapisać

    Code:

    Sub Macro1()
    Dim POTS(1 To 2) As Variant
     POTS(1) = "0.2"
     POTS(2) = "0.3"
    Dim DSL(1 To 2) As Variant
     DSL(1) = "0.4"
     DSL(2) = "0.5"
    Dim inne(1 To 2) As Variant
     inne(1) = "0.6"
     inne(2) = "0.7"

    ' sprawdzenie ilosci wierszy w bazowej tabeli
    ostatniWiersz = ThisWorkbook.ActiveSheet.Range("A1").End(xlDown).Row
    pierwszyWiersz = 2 'bo od drugiego wiersza
     
    grupa = InputBox("Podaj nazwę grupy") ' LUB ZASTOSOWAĆ WYPISANIE GRUP NA SZTYWNO
     
        'SPRAWDZANIE PRZYNALEŻNOŚCI NAZWISK DO GRUPY
     For b = 2 To Sheets("Arkusz2").Range("B1").End(xlDown).Row
        If Sheets("Arkusz2").Range("B" & b) = grupa Then
        adres = Sheets("Arkusz2").Range("A" & b).Value
            For i = 2 To Sheets("Arkusz1").Range("B1").End(xlDown).Row
                If Sheets("Arkusz1").Range("B" & i).Value = adres Then
                     Sheets("Arkusz1").Range("B" & i).Rows.Group       'GRUPOWANIE
                   'OBLICZENIA DLA GRUPY
                                    If Range("A" & i) = "POTS" Then
                                            If Range("F" & i) = "Dystrybucja" Then
                                                Range("H" & i) = POTS(1)
                                                If IsNumeric(Range("G" & i).Value) Then
                                                Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                                                End If
                                            ElseIf Range("F" & i) = "Anulowanie" Then
                                                Range("H" & i) = POTS(2)
                                                If IsNumeric(Range("G" & i).Value) Then
                                                Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                                                End If
                                    End If
                                         
                                    ElseIf Range("A" & i) = "DSL" Then
                                          If Range("F" & i) = "Dystrybucja" Then
                                              Range("H" & i) = DSL(1)
                                              If IsNumeric(Range("G" & i).Value) Then
                                              Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                                              End If
                                          ElseIf Range("F" & i) = "Anulowanie" Then
                                              Range("H" & i) = DSL(2)
                                              If IsNumeric(Range("G" & i).Value) Then
                                              Range("I" & i) = Range("H" & i) * Range("G" & i).Value
                                              End If
                                          End If
                                    End If                               
                End If
            Next
        End If
     Next
    End Sub

  • #15 04 Paź 2009 09:26
    adamas_nt
    Moderator Programowanie

    jaro99 napisał:
    chciałbym jeszcze aby po pogrupowaniu grupy zostały posortowane
    Raczej należy zrobić to jednocześnie. Przykład: liczby 1,2,3,4,5, grupa A liczby parzyste, B nieparzyste. Wybierając ze zbioru za pomocą pętli te, których reszta z dzielenia przez 2=0, ilość przebiegów = ilości wierszy do grupowania...

  • #16 08 Paź 2009 14:42
    jaro99
    Poziom 8  

    do poprzedniego makra muszę dodać funkcję która wyszuka mi 3 najwyższe wyniki wśród kolumny,w której znajdują się puste komórki i komórki z wynikami
    np. komórki 1-6 pusto, komórka 7=56,5, komórki 8-9 pusto, komórka 10=43,2 itd.
    zrobiłem pseudokod, który wyszukuje niezerowe wiersze, a wśród nich najwyższy wynik, lecz nie wiem jak zrobić żeby wyszukiwał mi drugi i trzeci najwyższy wynik

    Code:

    For t = 2 To Range("A1").End(xlDown).Row
        If Cells(t, 10) <> "" Then   'najlepszy wynik 1
          first = Cells(t, 10).Value
            If first > temp Then
                temp = first
            End If
           For g = t To Range("A1").End(xlDown).Row
            If Cells(g, 10) <> "" Then
                nowy = Cells(g, 10).Value
                    If nowy > temp Then
                        temp = nowy
                    End If
            End If
           Next
           max1 = temp
           Cells(g, 12) = max1
        End If
    Next
    For t = 2 To Range("A1").End(xlDown).Row
        If Cells(t, 10) <> "" Then   'najlepszy wynik 2
          drugi = Cells(t, 10).Value
            If drugi > temp2 Then
                temp2 = drugi
            End If
           For g = t To Range("A1").End(xlDown).Row
            If Cells(g, 10) <> "" Then
                nowy2 = Cells(g, 10).Value
                    If nowy2 > temp2 Then
                        If nowy2 < max1 Then
                            temp2 = nowy2
                        End If
                    End If
            End If
           Next
           max2 = temp2
           Cells(g, 13) = max2
        End If
    Next


    co do tego grupowania z poprzedniego postu to niezupełnie o to mi chodziło, nie mogę tego zrobić za pomocą liczb parzystych i nieparzystych bo mam kilka grup z nazwiskami, które są pomieszane ze sobą w wierszach a mają się połączyć w grupy i ustawić powiedzmy alfabetycznie (choć niekoniecznie), po prostu jedna grupa musi mieć wszystkie wiersze z nazwiskami do niej należącymi jedno pod drugim, potem druga grupa itd)

  • Pomocny post
    #17 08 Paź 2009 21:41
    adamas_nt
    Moderator Programowanie

    Podałem Ci tylko przykład na liczbach. Chodzi o to, że jeśli najpierw pogrupujesz wiersze a w następnej kolejności posortujesz, to grupowanie wierszy się nie zmieni bez względu na wynik sortowania. W trakcie wybierania nazwisk do grupy licz wiersze do pogrupowania i po umieszczeniu nazwisk grupy w arkuszu, uruchom grupowanie wg. licznika wierszy.

    Ad. trzy najwyższe. Można zastosować funkcję Excela MAK.K(tablica,k). W VBA

    Code:
    Application.WorksheetFunction.Large(Arg1, Arg2)

  • #18 26 Paź 2009 11:16
    jaro99
    Poziom 8  

    adamas_nt dzięki jeszcze raz za pomoc, miałem teraz trochę przerwy w zabawie z VB, ale projekt już skończyłem i wszystko mi działa:)

    tylko mam pewien problem z uruchamianiem tych makr, gdyż będzie ich używać osoba średnio znająca się na excelu, że nie wspomnę o kodach VB itp. i chciałbym ułatwić to na maksa, bo teraz kiedy chce go użyć to muszę:
    - za każdym razem otworzyć arkusz z tym makrem, żeby pojawiło mi się w Excelu/Narzędzia/Makro/Uruchom makro
    - i/lub skopiować kod makra, wklejać go do nowego arkusza, na którym chcę aby operowało, zapisywać i dopiero uruchamiać (nie działa mi opcja gdy mam otwarty arkusz z makrem ,a ja chcę uruchomić dane makro na nowym/innym arkuszu, muszę wtedy skopiować do niego kod makra,zapisać i wtedy działa bez problemu)

    interesuje mnie to żeby to makro było na stałe zaimplementowane w Excelu/Narzędzia/Makro/Uruchom makro bez konieczności otwierania pliku z tym makrem oraz/lub kopiowania kodu makra, wklejania go do nowego arkusza, na którym chcę aby operowało, zapisywania i dopiero uruchamiania.
    Chciałbym chociaż żeby wystarczyło za każdym otworzyć arkusz z makrem i żeby była możliwość uruchomienia go na nowym arkuszu

    Próbowałem już przypisać nowy przycisk do tego makra i fakt działa, ale tylko gdy do danego arkusza skopiuje kod makra...a chciałbym żeby na stałe działało...

    z góry dzięki za pomoc, pozdrawiam

  • Pomocny post
    #19 26 Paź 2009 19:53
    adamas_nt
    Moderator Programowanie

    Rozwiązań jak zwykle jest kilka. Jednak w związku z tym, że makro wykonuje działania na konkretnym arkuszu i określonych zakresach umieściłbym je pod przyciskiem, a cały plik bez wpisanych danych najlepiej byłoby zapisać jako szablon. Użytkownika łatwo będzie nauczyć klikać: Plik>Nowy z wyborem odp. szablonu... Można nawet dołączyć jakiś Help lub dodatkowy arkusz z "instrukcją obsługi".

  • #20 27 Paź 2009 09:19
    jaro99
    Poziom 8  

    to rozwiązanie niestety nie działa w moim przypadku, ponieważ faktycznie makro wykonuje działania tylko na określonych typach arkuszy, ale za każdym razem jak je otrzymuje to dostaję już wpisane dane, to jest plik z logami z innego programu i bez wpisanych danych plik byłby pusty, więc użytkownik już nie wpisuje danych, tylko je przetwarza na własny użytek(tworzenie raportów), zatem tworzenie szablonu do którego wpisuje się dane tutaj nie spełnia założeń.
    sposób obsługi jest taki,a przynajmniej chciałbym aby taki był;) :
    1.dostaję plik z logami
    2.uruchamiam makro przez przypisany przycisk
    3.makro tworzy mi nową kartę w tym samym arkuszu gdzie umieszcza przetworzone dane

    -zarejestrowałem makro "na stałe" i przechowywuje je w skoroszycie makr osobistych - to rozwiązanie daje mi na stałe przypisane makro w Excelu/Narzędzia/Makro/Uruchom makro/PERSONAL.XLS!Raportowanie
    tak więc nie muszę go za każdym razem rejestrować do nowych plików, co z tego jak jednak wciąż nie działa mi z nowymi arkuszami...
    może problem jest w kodzie z pobieraniem danych z aktualnie otwartego arkusza
    robię to tak że przypisuje nazwę aktualnie otwartego arkusza - w domyśle jest to nowy plik z logami, którego nazwę pobiera makro i wykorzystuje do pobierania i przetwarzania danych w obrębie makra:
    nazwa_arkusza = ThisWorkbook.ActiveSheet.Name 'może problem jest tutaj podczas przypisywania ścieżki pliku?
    Sheets.Add.Name = "Raport duży" - tworzy nowy arkusz do którego potem wpisuje dane, jak poniżej
    .
    .
    Sheets("Raport duży").Cells(m, 1).Value = Sheets(nazwa_arkusza).Cells(j, 1).Value

    -gdy to samo makro rejestruję w Excelu/Narzędzia/Makro/Uruchom makro/nazwa_tego arkusza.XLS!Raportowanie przypisując do tego konkretnego arkusza to wszystko działa bez problemu uruchamiane przyciskiem, gdy jednak pod przycisk przypiszę znowu w Excelu/Narzędzia/Makro/Uruchom makro/PERSONAL.XLS!Raportowanie to już przestaje działać...

  • Pomocny post
    #21 27 Paź 2009 20:47
    adamas_nt
    Moderator Programowanie

    Nie ma uniwersalnego rozwiązania w takim przypadku. Można oczywiście zapisać plik z makrem jako dodatek i aktywować go w oknie "dodatki", ALE: jeśli ktoś zmieni nazwy, kolejność indeksów arkuszy (jeśli nie nazwy) to kicha.
    Spróbuj może w ten sposób:
    1. Dostajesz plik z logami (gdzieś trzeba by go zapisać). Tutaj arkusz z danymi musi być rozpoznawalny.
    2. Otwierasz roboczy skoroszyt z makrem.
    3. Importujesz dane (arkusz z logami) do roboczego Np przy pomocy przycisku (lub z automatu) z oknem browsera do wyboru pliku źródłowego.
    4. Przetwarzasz dane.
    5. Eksportujesz gotowy arkusz z wynikami (kontynuacja głównego makra) do nowego pliku lub z powrotem do źródłowego.

  • #22 28 Paź 2009 00:58
    jaro99
    Poziom 8  

    na chwilę obecną poradziłem sobie w dosyć podobny sposób:
    1.zapisałem sobie 2 puste pliki z zarejestrowanymi makrami
    2.otwieram plik z logami
    3.kopiuje zawartość do plików z pkt1
    4.uruchamiam makro które mi przetwarza dane i tworzy pliki wynikowe-raporty

    właśnie mam taką sytuację ,że zmieniają mi się nazwy i kolejność arkuszy -,-
    trudno użytkownik będzie sobie musiał poradzić, uprościłem to na ile mogłem z Twoją dużą pomocą za którą wielkie dzięki!:)

 
Promocja -20%
Zamknij 
Wyszukaj w ofercie 200 tys. produktów TME
tme