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
ID tematu: 72901 Skopiuj do schowka Makro VBA zliczające procenty
Autor Wiadomość
darko2000 
Starszy Forumowicz


Wersja: Win Office 2019
Posty: 44
Wysłany: 04-06-2022, 18:24   

chyba nie ma opcji żebyśmy się dogadali, nie wiem jak Pan może twierdzić że jest dobrze wycinek z pańskiego pliku, który Pan zamieścił (nic nie zmieniane, nie przepuszczane jeszcze raz)
Pan sprawdza tylko kolumny AN, AO, AR, AS i tam prawie jest ok, ale dobre wyniki mają być jeszcze w kolumnach AZ, BA, BD, BE, BL, BM, BP, BQ, BX, BY, CB, CC, proszę np. ręcznie z kolumny AK wybrać 3 dostawcę, ustawić się w kolumnie CA, posortować procenty od największego do najmniejszego, i mamy np. w kolumnie CA największą wartość 8,14% więc w kolumnie CB ma 1 i to jest ok bo mieści się w 90% ale już w kolumnie CC ma wartość 2 chodź to jest najlepszy produkt więc powinien mieć 1 itd.

błąd2.jpg
Plik ściągnięto 4 raz(y) 100.05 KB

ID posta: 417759 Skopiuj do schowka
 
 
Tajan


Pomógł: 5155 razy
Posty: 11264
Wysłany: 04-06-2022, 18:58   

Jeszcze raz przeczytałem uważnie wszystkie posty i teraz rozumiem :-) W pierwszym poście napisałeś:
Cytat:
jeżeli w kolumnie AN będą już 1 to niech poflirtuje kolumnę AM od największej wartości
a tobie chodziło o sortowanie. Ja, niestety, trochę "po łebkach" przeczytałem i oparłem się na makrze, które pokazał Kaper. Teraz wszystko jasne! Spróbuję coś wykombinować ...
ID posta: 417761 Skopiuj do schowka
 
 
Tajan


Pomógł: 5155 razy
Posty: 11264
Wysłany: 05-06-2022, 08:24   

Proponuję zatem następujący kod:
Kod:
Sub Test()

    Dim lr As Long, i As Long
    Dim kolumny, kol
    Dim adres As String
    Dim tabela As Range

   
    kolumny = Array("AM", "AQ", "AY", "BC", "BK", "BO", "BW", "CA")

    If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False

    lr = Cells(Rows.Count, "AK").End(xlUp).Row
   
    Set tabela = Range("A3:AV" & lr)
   
    For i = 1 To 6
       
        tabela.AutoFilter Field:=37, Criteria1:=i
       
        For Each kol In kolumny
            adres = kol & "4:" & kol & lr
            Oblicz Range(adres)
        Next kol
   
    Next i

    ActiveSheet.AutoFilterMode = False

End Sub

Sub Oblicz(kolumna As Range)
    Dim myRecordset As Object
    Dim ost As Long
    Dim i As Long
    Dim cell As Range
    Dim suma As Double
   
    Const aVarChar = 200
    Const aDouble = 5
    Const aInteger = 3
   
    Set myRecordset = CreateObject("ADODB.Recordset")
   
    With myRecordset
                     
        With .Fields
            .Append "Adres", aVarChar, 255
            .Append "Procent", aDouble
            .Append "Pozycja", aInteger
        End With
           
        .Open
           
        For Each cell In kolumna.SpecialCells(xlVisible)
            .AddNew Array("Adres", "Procent"), Array(cell.Address, cell.Value)
        Next
           
        .Sort = "Procent DESC"
             
        .MoveFirst
           
        suma = 0
       
        Do Until .EOF
            If suma < 0.9 Then
                suma = suma + !Procent
                i = i + 1
                !Pozycja = i
            Else
                !Pozycja = 1000
            End If
            .MoveNext
        Loop
           
        .MoveFirst
             
        Do Until .EOF
            Range(!adres).Offset(0, 1).Value = IIf(!Pozycja = 1000, Empty, 1)
            Range(!adres).Offset(0, 2).Value = !Pozycja
            .MoveNext
        Loop
           
        .Close
   
    End With
   
    Set myRecordset = Nothing

End Sub
Mam nadzieję, że teraz dobrze zrozumiałem intencje.

test(tj).xlsm
Pobierz Plik ściągnięto 16 raz(y) 523.84 KB

ID posta: 417765 Skopiuj do schowka
 
 
darko2000 
Starszy Forumowicz


Wersja: Win Office 2019
Posty: 44
Wysłany: 05-06-2022, 09:36   

sprawdziłem jednego dostawcę przez wszystkie pola i wygląda to dobrze :clap resztę sprawdzę w poniedziałek
ID posta: 417766 Skopiuj do schowka
 
 
darko2000 
Starszy Forumowicz


Wersja: Win Office 2019
Posty: 44
Wysłany: 07-06-2022, 18:57   

dzięki bardzo wygląda wszystko ok, :lol:
ID posta: 417837 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.wip.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