Elektroda.pl
Elektroda.pl
X
Proszę, dodaj wyjątek www.elektroda.pl do Adblock.
Dzięki temu, że oglądasz reklamy, wspierasz portal i użytkowników.

[VBA] [EXCEL] Pętlą "Do Until...Loop"-jak to zrobi

Moned 10 Lis 2010 22:59 9312 31
  • #1 10 Lis 2010 22:59
    Moned
    Poziom 9  

    Witam.
    Mam taki oto problem.
    Wszystko było by ok ale w excel-u nie da sie zrobić pętli warunkowej i trzeba skorzystać z VBA.
    Niestety już drugą noc ślęczę nad tym i nic...
    Chodzi o stworzenie pętli "Do Until ...Lopp" i bloku instrukcji w tej pętli.
    Analizując w excel-u zajmiemy sie kolumną B.
    Uzyskany wynik ma sie zawierać w przedziale B20 i B21
    B20 = 8 natomiast B21= 8,9 i to są stałe niezmienne, (oczywiście w innej kolumnie będą inne stałe i nigdy nie przekroczą wartości 100 - piszę o tym ponieważ program musi być w miarę szybki a mając prawidłowo działającą pętlę w kolumnie B poradzę sobie z innymi kolumnami.)

    Następnie w kolumnie B5 mamy wartość zmienną.

    Kolumna B5 jest mnożona z B13 a wynik to B14 i on właśnie musi się mieścić między 8 a 8,9 w tedy warunek jest spełniony i pętla kończy program.
    Jeśli warunek jest nie spełniony to pętla dodawała by do B5 wartość 0.1, (lub odejmowała 0.1).
    Wartość B5 będzie prawidłowa tylko w tedy gdy będzie spełniony warunek z zakresu od B20 do B21.
    Kolumna B13 może przyjąć wartość tylko i wyłącznie 3, 6 lub 9 jest to wprowadzane ręcznie. Po wprowadzeniu tej danej w Excel-u miało by nastąpić automatyczne uruchomienie pętli którą właśnie opisuje.
    Jeśli warunek jest nie spełniony pętla ma się zapętlać tak długo aż osiągnie żądany warunek dla B5 . Pętla nie powinna zawierać awaryjnego zamknięcia ponieważ warunek na pewno kiedyś zostanie spełniony.
    (Uzyskany wynik może mieć wpływ na kolumnę C5 ale to akurat nie ma znaczenia.)

    To samo na przykładzie.
    Załóżmy że w B13 musze wprowadzić 6
    B13=6 * B5=1,2 =B19

    B20=8
    B21=8,9
    pętla - ma dodawać (lub odejmować) 0,1 do B5 aż warunek zostanie spełniony.

    B13*B5 ma być = B20 do B21 warunek ten jest nie spełniony, wiec pętla szuka rozwiązania. Za każdym razem kiedy pętla jest nie spełniona dodaje do B5 +0,1
    Aż B5=1,4 wtedy
    B5*B13=
    1,4*6=8,4
    a 8,4 zawiera się między B20 a B21 mnie satysfakcjonuje nowy wynik w polu B5 jeśli spełniony zostanie warunek pętli.

    Ale sytuacja może też być odwrotna bo jeśli będę musiał podstawić za B13 liczbę 9 to w tedy
    B13=9 * B5=1,2 =B19
    = 10,8
    Wiec aby zmieścić sie miedzy 8 a 8,9 musze odjąć z B5-0,1
    Wynikiem jest B5 którego NOWA wartość wynosiła by 0,9.

    W tym miejscu wydaje mi się że jest to największy problem.
    Proszę o pomoc w napisaniu takiej pętli nie mam bladego pojęcia jakich instrukcji użyć w pętli "Do Until". Jest to jedyna sytuacja w której musze skorzystać z VBA.

    Proszę poprawić błędy w poście! Ortografia i brak kropek!
    Proszę, zgodnie z regulaminem pkt 11.1, o usunięcie słów PROBLEM lub/i POMOC z tytułu. Prośba dotyczy także wszelkich wariacji typu: kłopot, pomocy, problemy itd.
    - arnoldziq

    0 29
  • Pomocny post
    #2 10 Lis 2010 23:26
    adamas_nt
    Moderator Programowanie

    W zależności od sytuacji można dodawać 0,1 pomnożone przez 1 lub -1 Np

    Code:
    If Range("B19") < Range("B20") Then knyps = 1
    
    If Range("B19") > Range("B21") Then knyps = -1

    Do Until Range("B19") >= Range("B20") And Range("B19") <= Range("B21")
      Range("B5") = Range("B5") + 0.1 * knyps
    Loop

    0
  • #3 11 Lis 2010 10:55
    Moned
    Poziom 9  

    Wiem że początek ma wyglądać tak:

    Sub KOREKTA
    Do Until

    Od tego miejsca nie wiem jak dalej mam to zrobić w programie.
    Proszę o pomoc w napisaniu dalszej instrukcji do słowa "Loop" które kończy działanie pętli.

    Dodano po 33 [minuty]:

    Dziękuję Panie adamas_nt.
    Wygląda to na świetną robote. Wieczorem zmodyfikuje kod do innych kolumn i dam znać czy jest ok.

    0
  • #4 11 Lis 2010 18:52
    Moned
    Poziom 9  

    Ok kod działa poprawnie, podziękowania dla Pana adamas_nt który zrobił to błyskawicznie!
    Niestety mam jeszcze jeden problem.
    Co zrobić aby to zautomatyzować ?
    Dokładnie chodzi mi o to aby po wprowadzeniu wartości w B13 napisana pętla zaczęła działać sama.
    (Obecnie zrobiłem przyciski, ale jest tego zbyt wiele, a ja potrzebuje pełnej automatyzacji więc ten pomysł odpada), konieczne jest zmodyfikowanie kodu a ja nie wiem co jeszcze dopisać do kodu użytkownika adamas_nt aby działało w sposób automatyczny.

    0
  • #5 11 Lis 2010 19:35
    adamas_nt
    Moderator Programowanie

    Umieść procedurę w kodzie arkusza Np przy zmianie, z ograniczeniem do B5 i B13. Tzn w przykładzie

    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Address(0, 0) = "B5" Or Target.Address(0, 0) = "B13" Then
      If Range("B19") < Range("B20") Then knyps = 1
      If Range("B19") > Range("B21") Then knyps = -1
     
      Do Until Range("B19") >= Range("B20") And Range("B19") <= Range("B21")
        Range("B5") = Range("B5") + 0.1 * knyps
      Loop
    End If
    End Sub
    makro działa tylko przy zmianie w tych dwóch komórkach. Możesz oczywiście ograniczyć do jednej...

    Natomiast dla zakresu można zmienić warunek na
    Code:
    If Not Intersect(Target, Range("B13:C13")) Is Nothing Then
    a całość opierasz na przesunięciu. Np zamiast Range("B19")
    Code:
    Target.Offset(6, 0)
    (plus 6 wierszy od B lub C13).

    0
  • #6 11 Lis 2010 20:58
    Moned
    Poziom 9  

    1.Ten kod nie działa.
    Kopiuje i wklejam dokładnie taki jak jest a on nie działa.
    2.Program powinien działać tylko i wyłącznie po zmianie wartości w polu B13.

    0
  • #8 11 Lis 2010 21:39
    Moned
    Poziom 9  

    Ale jak mam to zrobić ?

    adamas_nt napisał:
    Wklej w kod arkusza...

    0
  • #9 11 Lis 2010 21:56
    adamas_nt
    Moderator Programowanie

    Kliknij prawym pm w zakładkę arkusza z nazwą (u dołu ekranu), wybierz "wyświetl kod"...

    p.s
    Na Twoim miejscu jednak zabezpieczyłbym się przed pętlą nieskończoną. Dość łatwo o to chociażby przez pomyłkę. Testowałem trochę. Dla liczb 88, 44-41, 29-27 i od 22-0 jest OK. Pozostałe "badają wytrzymałość procesora" :)

    Wydaje się niezbędne

    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Address(0, 0) = "B13" Then
      If Target <= 0 Then Target = 0.1
      If Range("B19") < Range("B20") Then knyps = 1
      If Range("B19") > Range("B21") Then knyps = -1
     
      Do Until Range("B19") >= Range("B20") And Range("B19") <= Range("B21")
        Range("B5") = Range("B5") + 0.1 * knyps
        If Range("B5") <= 0 Then
          Range("B13") = Range("B13") - 1
        End If
        If Range("B19") > Range("B21") * 10 Then
          Range("B13") = Range("B13") - 1
          Exit Do 'tu przeliczy, nastąpi zmiana i pójdzie dalej
        End If
      Loop
    End If
    End Sub

    0
  • #10 11 Lis 2010 22:58
    Moned
    Poziom 9  

    W Visual Basic-u mam karte a w niej "General" którego nie moge zmienić na "Worksheet" i tym samym po prawj nie mam możliwości wybrania "Chanage"
    Jak to mam zrobić?

    0
  • #11 11 Lis 2010 23:14
    adamas_nt
    Moderator Programowanie

    Hmm, z tym się jeszcze nie spotkałem.
    Na pewno aktywny masz arkusz NIE moduł (dwuklik, browser z lewej)?
    Jaką masz wersję Excela? Wrzuć zrzut ekranu informacji. Np u mnie:

    [VBA] [EXCEL] Pętlą "Do Until...Loop"-jak to zrobi

    0
  • #12 11 Lis 2010 23:44
    Moned
    Poziom 9  

    Ten plik od Ciebie mi działa, ale osobiście nie mogę takiego samego utworzyć .
    Może ja coś źle robię, wiec opisze to:
    Z karty Insert wybieram module i nic nie moge zmienić w tych zakładkach. Wklejam więc twój kod i dalej nic nie moge zmienić. Tylko z prawej strony zmienia sie na tytuł "Worksheet_Change" i ewentualnie moge zmienić na "declarations".
    EXEL 2007 - narazie nie wiem gdzie szukać jaka to wersja.

    Dodano po 10 [minuty]:

    Już wiem
    Wygląda to tak jak by nie można było wprowadzić poraz kolejny wartości "Worksheet " tylko raz, a ja musze wprowadzić dla innych kolumn a nie tylko jedej kolumny.

    Dodano po 4 [minuty]:

    Chyba że w tym samym arkuszu moge kontynuować przepisywanie kodu dla innych kolumn, ale czy to zadziała i nie potrzebna jest już rzadna linia komend ?

    0
  • #13 12 Lis 2010 00:04
    adamas_nt
    Moderator Programowanie

    Moned napisał:
    Z karty Insert wybieram module
    Właśnie nie. Procedura ma znaleźć się w kodzie arkusza. Moduł w tym przypadku w ogóle nie jest potrzebny.

    [VBA] [EXCEL] Pętlą "Do Until...Loop"-jak to zrobi

    W kodzie arkusza możesz wstawiać dowolną ilość procedur zdarzeniowych, lokalnych, funkcji lokalnych itp. Jeśli mają mieć zasięg we wszystkich arkuszach (globalny), używasz modułu standardowego. Oczywiście wykluczając zdarzeniowe.
    Można też procedurę Sub umieścić w module a wywołanie (Call nazwa_procedury) w kodzie arkusza przy zdarzeniu. Zasadne w przypadku wykonywania tych samych czynności w wielu arkuszach (mniej kodu).

    0
  • #14 12 Lis 2010 00:14
    Moned
    Poziom 9  

    No dobrze ale w ten sposób moge wprowadzić dane tylko dla jednej kolumny.
    Jak wpowadzić dane dla kolejnych kolumn? Ewentualnie trzeba by coś dopisać do kodu, ale co ?

    0
  • #15 12 Lis 2010 00:18
    adamas_nt
    Moderator Programowanie

    Już o tym pisałem. Określić zakres Np dla 5 kolumn

    Code:
    If Not Intersect(Target, Range("B13:F13")) Is Nothing Then
    i działać offsetem...

    0
  • #16 12 Lis 2010 00:34
    Moned
    Poziom 9  

    adamas_nt napisał:
    (Uzyskany wynik może mieć wpływ na kolumnę C5 ale to akurat nie ma znaczenia.)...

    No to w takiej sytuacji okazało by się że ma znaczenie gdyż program wykona obliczenia dla kolejnych kolumn przed podjęciem decyzji co będzie w C5, D5 itp...
    Czy może coś namieszałem?

    Dodano po 6 [minuty]:

    Jednak działa z tą zmianą.
    Przetestuje jutro na większym zbiorze. Jeśli nie ma ograniczeń ilości kolumn będzie idealnie.

    0
  • #17 12 Lis 2010 00:36
    adamas_nt
    Moderator Programowanie

    Musisz sprowadzić makro do działania dla jednej kolumny. W załączniku przykład z wykorzystaniem modułu, procedury zdarzeniowej i przekazaniem argumentu (Nr kolumny), zdaje się bardziej zrozumiały od offset'owania...

    0
  • #18 12 Lis 2010 20:13
    Moned
    Poziom 9  

    O tym wcześniej nie pisałem, ale nie jest to też jakimś wielkim problemem:
    Bardziej chodzi o przejżystość tabeli, a wynikło to w trakcie wpisywania kodu.
    Chodzi o to że w exelu mam stworzony przycisk który naciskam po zakończeniu sesji a on wymazuje dane ze wszystkich kolumn 13. W ten sposób od nowa moge wprowadzać wartości w wierszu 13- jest większe prawdopodobieństwo że nie popełnie błędu opuszczając jakąś kolumnę 13. Obecnie podstawiając pustą wartość lub zero, automatycznie zostaje przypisane 0,1. Czy dało by się to zmienić ?

    0
  • #19 12 Lis 2010 21:17
    adamas_nt
    Moderator Programowanie

    Jeśli to "0,1" Ci nie przeszkadza, to zostaw bez zmian, bezpieczniej.
    Jeśli musisz mieć puste (i nie rezygnować z przycisku) to można wstawić spację, tym samym wymusić błąd i pominąć procedurę.

    Zmień kod w kodzie arkusza na

    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error GoTo koniec
    If Not Intersect(Target, Range("B13:F13")) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        If Target <= 0 Then Target = " "
        Call Korekta(Target.Column)
    End If
    koniec:
    End Sub

    0
  • #20 12 Lis 2010 21:19
    Moned
    Poziom 9  

    Najlepiej jak by się to dało zmienić (wstawić) na pustopole.
    Jeszcze pytanie na przyszłość bardziej tzn:
    Mam zamiar rozbudować moją kombinację o kolejny, lub kolejne poziomy.
    Czy jest możliwośc wprowadzenia nowego podobnego kodu dla innych wierszy?
    Przykładowo wiersz 5 był by 35 a wiersz 13 był by 43 itp. Poprostu dodatkowo był by wybudowany nowy poziom. Czy jest potrzebna w tedy głębsza modyfikacja kodu?.

    0
  • Pomocny post
    #21 12 Lis 2010 22:01
    adamas_nt
    Moderator Programowanie

    Moned napisał:
    Najlepiej jak by się to dało zmienić (wstawić) na pustopole
    Da się chyba. Spróbuj
    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
    
    On Error GoTo koniec
    If Not Intersect(Target, Range("B13:F13")) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        If Target <= 0 Then Target = "": Exit Sub
        Call Korekta(Target.Column)
    End If
    koniec:
    End Sub

    Zmiana zakresów to żaden problem, podstawiasz nowe numery wierszy w module i kodzie arkusza, i po sprawie.

    0
  • #22 12 Lis 2010 23:27
    Moned
    Poziom 9  

    Po zmianie mam takie wrażenie że dłużej liczy i gdzieś coś umyka, ale może się mylę bo jestem już zmęczony. Jutro sprawdze na całości i dam znać.

    0
  • #23 13 Lis 2010 07:03
    adamas_nt
    Moderator Programowanie

    Mi tam się podoba jak cyferki śmigają :)

    Wystarczy w module wyłączyć odświeżanie i na końcu koniecznie włączyć

    Code:
    Sub
    
    Application.ScreenUpdating = False
     (...)
    Application.ScreenUpdating = True
    End Sub

    0
  • #24 13 Lis 2010 10:17
    Moned
    Poziom 9  

    Czasem dzieje się coś dziwnego, prosze spróbować wpisać w pole E5 wartośc np 50 i wyliczamy E13 podstawiając np 9 program gubi się i sam za 9 podstawia dwujkę i wylicza. Wtym wypadku można wrócić i poprawić na 9 i wyliczy dobrze ale dopiero przy 2 próbie. U mnie w kolumnie "W13" nie da się już podstawić 9 komputer podstawia 5. Ja wisuje 9 a on zmienia na 5 i tak za każdym razem.
    Jeśli da się to zmienić dobrze by było żeby obliczał wszystko za pierwszym razem.
    (Jedynym sposobem jest zmiana wartości w wierszu 5 na mniejszą, no ale przeciez nie o to tu chodzi.) Proszę o pomoc w tej kwestii.

    0
  • #25 13 Lis 2010 10:53
    adamas_nt
    Moderator Programowanie

    Zwiększ eksperymentalnie dopuszczalną wartość komórki w wierszu 19 (linia 10 w module). Na początek

    Code:
    If Cells(19, kol) > Cells(21, kol) * 250 Then
    Zależy jakie maksymalne liczby wpisujesz w 5 i 13 wierszu. Policz. Sam widzisz, że to zabezpieczenie jest potrzebne. Gdyby go nie było, pętla w określonych warunkach nie skończyła by działania...

    0
  • #26 13 Lis 2010 14:54
    Moned
    Poziom 9  

    Tylko nie rozumiem tego. Jak to jest że wpisując nawet 20 dla E5 chciałbym wyliczyć wartość 6 dla E13 a on automatycznie zmienia na 5. Za drugim razem z tej wartości potrafi już wyliczyć 6. Tego nie mogę pojąć wychodziło by to tak jak by pętla miała ograniczenie np do X powtórzeń. Czy nie dało by się tego zakresu zwiększyć.
    Mam tymczasowo inny sposób na to ale wolał bym z niego nie korzystać.

    Słowo chciałbym pisze się razem a nie osobno.
    Post poprawiłem - arnoldziq

    0
  • Pomocny post
    #27 13 Lis 2010 17:17
    adamas_nt
    Moderator Programowanie

    Musisz dopasować eksperymentalnie. Bardziej "odporne" rozwiązanie to dzielenie "za dużej" liczby przez 2, zamiast odejmowania z w13

    Code:
    Sub Korekta(kol)
    
    Application.ScreenUpdating = False
      If Cells(5, kol) < 0 Then Exit Sub
      If Cells(19, kol) < Cells(20, kol) Then knyps = 1
      If Cells(19, kol) > Cells(21, kol) Then knyps = -1
     
      Do Until Cells(19, kol) >= Cells(20, kol) And Cells(19, kol) <= Cells(21, kol)
        Cells(5, kol) = Cells(5, kol) + 0.1 * knyps
        If Cells(19, kol) > Cells(21, kol) * 250 Then
          Cells(5, kol) = Int(Cells(5, kol)) / 2
        End If
      Loop
    Application.ScreenUpdating = True
    End Sub

    0
  • #28 13 Lis 2010 19:54
    Moned
    Poziom 9  

    Kod jest świetny a obliczenia działają teraz w 100%, nawet mnie się podoba jak to śmiga :D.
    Teraz jednak mam inny problem. Postanowiłem rozbudować kolumny i tak o to: Wszystko pozostaje tak jak było czyli wiersze 5,13,19,20 ,21 pozostają na swoim miejscu, dodatkowo dochodzą nowe i mają identyczne funkcje jak poprzednie i tak:
    5 ma swojego odpowiednika w wierszu 25 i 45
    13 ma 33 i 53
    19 ma 39 i 59
    20 ma 40 i 60
    21 ma 41 i 61
    Proszę o pomoc jak to mam zrobić aby obliczenia były takie jak te z ostatniego postu ? Nie wiem jak zmodyfikować kod. Co mam zrobić ?

    0
  • #29 13 Lis 2010 21:02
    adamas_nt
    Moderator Programowanie

    Najprościej byłoby przekazać dwa argumenty do procedury w module. Jeśli do tej pory Target.Row miał wartość 13, to trzeba przerobić makro. Wiersz 5 to 13-8, 20 to 13+7 itd. Czyli: w kodzie arkusza dodajesz warunki i argument

    Code:
    Private Sub Worksheet_Change(ByVal Target As Range)
    
    Application.EnableEvents = True
    On Error GoTo koniec
    If Not Intersect(Target, Range("B13:F13")) Is Nothing Or _
    Not Intersect(Target, Range("B33:F33")) Is Nothing Or _
    Not Intersect(Target, Range("B53:F53")) Is Nothing Then
        If Target.Count > 1 Then Exit Sub
        If Target <= 0 Then Target = "": Exit Sub
        Call Korekta(Target.Row, Target.Column)
    End If
    koniec:
    End Sub

    W module natomiast podstawiasz
    Code:
    Sub Korekta(wrs, kol)
    
    Application.ScreenUpdating = False
      If Cells(wrs - 8, kol) < 0 Then Exit Sub
      If Cells(wrs + 6, kol) < Cells(wrs + 7, kol) Then knyps = 1
      If Cells(wrs + 6, kol) > Cells(wrs + 8, kol) Then knyps = -1
    i.t.d

    Możesz skorzystać z Ctr+h (Np Raplace: "5," na "wrs-8,")

    0
  • #30 14 Lis 2010 12:30
    Moned
    Poziom 9  

    Szczerze to nie bardzo rozumiem o co w tym chodzi. Czy nie mógł byś zamieścić całego kodu ? Ewentualnie wytłumaczyć powoli bo, nie znam ni w ząb VBA .

    0