Excel Forum - Porady, Pomoc, Excel Help, Excel FAQ - Makro VBA zliczające procenty

darko2000 · Starszy Forumowicz Wersja: Win Office 2019 Posty: 44

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

Tajan · **Pomógł:** 5155 razy Posty: 11264

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ć ...

Tajan · **Pomógł:** 5155 razy Posty: 11264

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

darko2000 · Starszy Forumowicz Wersja: Win Office 2019 Posty: 44

sprawdziłem jednego dostawcę przez wszystkie pola i wygląda to dobrze :clap

resztę sprawdzę w poniedziałek

darko2000 · Starszy Forumowicz Wersja: Win Office 2019 Posty: 44

dzięki bardzo wygląda wszystko ok, :lol: