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: 64266 Skopiuj do schowka Zwrócenie komórek z minimalnymi wartości z osobnego zakresu
Autor Wiadomość
Switek25
Starszy Forumowicz


Posty: 39
Wysłany: 26-02-2019, 22:04   Zwrócenie komórek z minimalnymi wartości z osobnego zakresu

Witam,

utkwiłem z jednym zagadnieniem i będę wdzięczny za pomoc.

W zakresie A1:H5 posiadam wartości do komórek w zakresie A6:H10. Przykładowo komórce A6 odpowiada wartość komórki A1.

W zakresie A11:H15 potrzebuję zwrócić po dwie unikatowe wartości komórek w każdym wierszu, z zakresu A6:H10, których wartości w zakresie A1:H5 są minimalnymi wartościami w danym wierszu.

Przykładowo w zakresie A13:H13 zwracam wartości komórek A8 oraz E8 gdyż posiadają najniższe wartości w zakresie A3:H3.

Potrzebuję dodatkowo obsługiwać poniższe kryteria:

- jeżeli dwie minimalne komórki mają taki sam identyfikator (np. A7 i C7) to w C12 zwracam C7 i szukam kolejnej najniższej wartości (w tym wypadku G7),

- jeżeli dwie minimalne wartości komórek mają ten sam identyfikator i wartość (np. A6 i G6), to w zakresie A11:H11 zwracam losowo jedną z nich.

- pomijanie pustych pól w zakresie A6:H10

Dodaje załącznik 'Przykład', w którym czerwonym kolorem czcionki zaznaczyłem prawidłowo uzupełnione wartości, a czarnym dane wejściowe.

Będę wdzięczny za pomoc w skonstruowaniu formuły generującej takie wyniki.

Przykład.xlsx
Pobierz Plik ściągnięto 12 raz(y) 8.93 KB

ID posta: 363316 Skopiuj do schowka
 
 
Marecki 
Excel Expert



Wersja: Win Office 2019
Pomógł: 2079 razy
Posty: 6858
Wysłany: 02-03-2019, 16:15   

Co prawda nie jest to formuła tylko makro, bo formułą nie umiem tego zrobić.
Czy dobrze to zrobiłem - nie wiem.
Testuj, bo wyniki ciut się różnią od Twoich - konkretnie jeden.
Nie uwzględniłem w kodzie tego:
Switek25 napisał/a:
- jeżeli dwie minimalne wartości komórek mają ten sam identyfikator i wartość (np. A6 i G6), to w zakresie A11:H11 zwracam losowo jedną z nich.

ale ty też chyba nie podałeś wszystkich możliwych wariantów - np. co w przypadku gdy w danym wierszu będzie tylko jedna wartość, albo nie będzie wcale - czy może dojść do takiej sytuacji ?
Może ktoś dopisze te losowe wybieranie.
Kod jakoś opisałem, bo czasami sam się gubiłem w pętlach: :mrgreen:
Kod:
Option Explicit

Sub Test()
    Const kolumn       As Long = 8    'ilość kolumn z zakresu "A1:H5"
    Const wierszy      As Long = 5    'ilość wierszy z zakresu "A1:H5"
    Dim Rng            As Range       'zmienna dla zakresu "A1:H6"
    Dim Tbl_1          As Variant     'Tablica danych z zakresu "A1:H5"
    Dim Tbl_2          As Variant     'Tablica danych z zakresu "A6:H10"
    Dim Tbl_out()      As String      'Tablica wynikowa
    Dim Tbl_tmp        As Variant     'Tablica tymczasowa przyjmująca dane z jednego wiersza z tablicy Tbl_1
    Dim w              As Long        'zmienna iteracyjna wierszy
    Dim k              As Long        'zmienna iteracyjna kolumn
    Dim poz            As Byte        'zmienna podająca pozycję minimalną w wierszu tablicy Tbl_1
    Dim ex1            As Byte        'przełącznik w pętli "For k"
    Dim ex2            As Byte        'przełącznik w pętli "For k"
    Dim el             As Variant     'zmienna dla pętli "For Each"

    Range("A11").Resize(wierszy, kolumn).ClearContents       'czyścimy zakres wynikowy - "A11:H15"
    Set Rng = Range(Cells(1, 1), Cells(wierszy, kolumn))     'przypisujemy zakres "A1:H5" do zmiennej Rng
    Tbl_1 = Rng                                              'pobieramy dane do tablicy Tbl_1 z zakresu "A1:H5"
    Tbl_2 = Rng.Offset(wierszy)                              'pobieramy dane do tablicy Tbl_2 z zakresu "A6:H10"

    ReDim Tbl_out(1 To wierszy, 1 To kolumn)                 'tworzymy tablicę wynikową

    For w = 1 To wierszy                                     ' pętla po wierszach Tbl_2
        ex1 = 0
        ex2 = 0
        Tbl_tmp = SortArrayInt(Application.Index(Tbl_1, w, 0))    'pobieramy dane z wiersza "w" - posotrowane rosnąco

        For k = 1 To kolumn                                    'pętla po kolumnach Tbl_2
            If Tbl_tmp(k) <> 0 Then                            'jeżeli watrość jest różna od zera to
                ex1 = ex1 + 1
                poz = Application.Match(Tbl_tmp(k), Application.Index(Tbl_1, w, 0), 0)    ' ustalamy pozycję minimalną w wierszu "w" tablicy Tbl_1
                Tbl_1(w, poz) = 0                                                      ' zmieniamy wartość min na zero by wyszukać kolejną min

                If ex1 = 1 Then
                    Tbl_out(w, poz) = Tbl_2(w, poz)                                    'wpisujemy pierwszą wartość do tablicy wynikowej Tbl_out
                Else

                    For Each el In Application.Index(Tbl_out, w, 0)                    'pętla po wierszach "w" tablicy Tbl_out
                        If el = Tbl_2(w, poz) Then ex2 = ex2 + 1: Exit For             'sprawdzamy duplikaty
                    Next el

                    If ex2 = 0 Then                                                    'jeżeli ich nie ma to:
                        Tbl_out(w, poz) = Tbl_2(w, poz)                                'wpisujemy drugą wartość do tablicy wynikowej Tbl_out
                        Exit For                                                       'wychodzimy z pętli "For k"
                    End If
                    ex2 = 0
                End If
            End If
        Next k
    Next w                                                                              'i przechodzimy do kolejnego wiersza Tbl_2

    Range("A11").Resize(wierszy, kolumn).Value = Tbl_out                                ' zwracamy zebrane wyniki z Tbl_out do zakresu "A11:H21"

End Sub

'Funkcja sortująca dane liczbowe w kolejności rosnącej
Function SortArrayInt(vArr As Variant) As Variant
    Dim msSC           As Object
    Dim Tbl_tmp_in     As Variant
    Dim i              As Long

    On Error GoTo SortArrayInt_Error

    Set msSC = CreateObject("ScriptControl")
    ReDim Tbl_tmp_out(1 To UBound(vArr)) As Double

    With msSC
        .Language = "JScript"
        .AddCode "function MySort(arr) {return arr.toArray().sort(function(a, b){return a-b}).join('\b');}"
        Tbl_tmp_in = Split(.Run("MySort", vArr), Chr(8))
    End With

    For i = 1 To UBound(vArr)
        Tbl_tmp_out(i) = Tbl_tmp_in(i - 1)
    Next i
    SortArrayInt = Tbl_tmp_out

    Set msSC = Nothing
    Erase vArr
    Erase Tbl_tmp_in
    Erase Tbl_tmp_out

    On Error GoTo 0
    Exit Function

SortArrayInt_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure SortArrayInt of Module Module1"

End Function


Przykład(1).xlsm
Pobierz Plik ściągnięto 6 raz(y) 28.67 KB

_________________
Hardware - ta część komputera, którą można kopnąć kiedy software przestanie funkcjonować.

Szkolenia z Excela , FB
Office 2019 Professional Plus , Windows 10 x64
Pozdrawiam, były mkkk23 teraz Marecki.
ID posta: 363540 Skopiuj do schowka
 
 
Switek25
Starszy Forumowicz


Posty: 39
Wysłany: 10-03-2019, 20:22   

Dziękuję za poświęcony czas!

makro działa jak najbardziej prawidłowo i jest odpowiedzią na moje zapotrzebowanie. Zaimplementowałem je do szerszego zakresu i nie napotkałem problemów.

Nie będzie sytuacji, w której wiersz będzie zawierał tylko jedną wartość wiec nie ma potrzeby tworzenia do tego warunku, ale dziękuję za uwagę.

Odnośnie losowego wybierania, planuje spróbować użyć funkcji Los() i zwracać komórkę, dla której przypisana będzie najwyższa wartość.

Jeszcze raz dziękuję za pomoc!
ID posta: 363929 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.marketingNET.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