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

Excel - wyszukaj pionowo dla tekstu w jednej komorce

29 Lip 2015 12:05 1518 10
  • Poziom 12  
    Witam,

    Myślę nad zrobieniem czegoś w stylu wyszukaj.pionowo + zamień, dla tekstu zawartego w jednej komorce.

    Chodzi o to że z innego skoroszytu chce wyciągać wartości odpowiadające tekstowi zawartemu w powiedzmy komórce C1. Nie byłoby w tym nic trudnego gdyby w tej komorce znadowal sie tekst tylko dla jednego rekordu a wynik wyszukaj pionowo mialby trafic do komorki obok.

    Zakładamy ze C1 wygląda tak:

    xxx-yyy-zzz-aaa-bbb-ccc


    W drugim skoroszycie mam listę gdzie w kolumnie A jest w oddzielnej komórce po kolei (aaa, bbb, ccc, xxx, yyy, zzz) a w kolumnie B odpowiadajace temu wartosci liczbowe (np odpowiednio 10, 4, 6, 11, 2, 5).

    Chodzi o to, że wartości liczbowe przypisać do tekstu w C1 na zasadzie:

    xxx(11)-yyy(2)-zzz(5)-aaa(10)-bbb(4)-ccc(6)

    To znów nie byłoby trudne, bo wystarczyłoby ogarnąć jakieś nagrane makro na kolumny jako tekst, dalej wyszukaj pionowo i potem odpowiednie zastosowanie formuly złącz.tekst.

    Problem w tym, że te rekordy z listy i to czy przypisac czy nie sa obarczone problemem logicznym, którego opisanie w excelu może być trudne. Dlatego wpadłem na pomysł, żeby wstepnie oznaczac w danej komorce np w sposob nastepujacy:

    xxx-yyy(?)-zzz-aaa(?)-bbb-ccc(?)

    I znów byłoby łatwo jeżeli te rekordy byłby takie same dla wszystkich komórek (sam tak robie jeżeli jest możliwość). Wtedy wystarczyłoby dać zwykłe znajdz i zamień (?) na wskazaną wartość.

    Więc co chce zrobić to połączyć jakoby funkcje wyszukaj.pionowo i znajdz i zamień.

    Pisząc łopatologicznie szukamy to co jest między '-' a (?), dalej wyszukujemy jakie sa wartosci w tych znalezionych rekordach w innym skoroszycie i wpisujemy odpowiednie wartosci

    Więc wyglądałoby to tak:
    dla tej kolumny C1 wyszukuje w skoroszycie wartosci yyy, aaa i ccc i zamienia je na:

    xxx-yyy(2)-zzz-aaa(10)-bbb-ccc(6)

    Dodatkowo znalezione i przepisane wartosci z tamtego skoroszytu zmienia np kolor tła (tak żeby było wiadomo czy jest coś wpisane czy nie). Domyślam się że część będzie trzeba ręcznie i tak wpisac. Ale oznaczenie wybranych ciągów tekstowych i automatyczna zmiana ich na wartosci z drugiego skoroszytu.

    Co może być pomocne to coś w czym pomógł mi jakiś czas temu użytkownik JRV. Stworzył on makro, które działa idealnie. Dzieli tą pojedynczą komórkę zapisaną w postaci:

    xxx-yyy-zzz-aaa-bbb-ccc

    na oddzielne kolumny dla xxx, yyy, zzz, aaa, bbb, ccc (między tym wstawia 3 kolumny gdyż pojawiają się czasem dodatkowe parametry w nawiasie przy tych rekordach rozdzielane dwoma średnikami na zasadzie

    xxx(;;)-yyy(;;) - rozdzielane na xxx -> 3 kolumny puste (to co przed pierwszym srednikiem w pierwsza kolumne po xxx to co miedzy średnikami w druga kolumne i wszystko co po drugim sredniku az do zamknietego nawiasu w trzeciej kolumnie. Nasz znak zapytania trafiałby między średniki czyli rozdzielany na zasadzie wartosc ze skoroszytu do drugiej kolumny za xxx.

    Makro wyglada tak:

    Code:

    Sub stary_nowy()
    tt = Timer
    Dim bs As Range, bd As Range   
    With Sheets("stary")
        ostw = .Cells(Rows.Count, 3).End(xlUp).Row
        Set bs = .Range(.Cells(1, 1), .Cells(ostw, 3)).Cells   
    End With
    Set bd = Sheets("nowy").Cells 
    bd(3, 1).Resize(Rows.Count - 2, Columns.Count).ClearContents   
    rs = 1: rd = 2 
    While rs <= bs.Rows.Count 
        If bs(rs, 3) <> vbNullString Then 
            rd = rd + 1
            bs(rs, 1).Resize(1, 2).Copy bd(rd, 1)     
            tras = Trim(bs(rs, 3))
            p = 0: sk = 0 
            While p < Len(tras)
                csk = sk * 4 + 3   
                p1 = p + 1
                p = InStr(p1, tras, "-")   
                If p = 0 Then p = Len(tras) + 1
                itr = Trim(Mid(tras, p1, p - p1)) 
                nz = 0: Z = 0
                n = InStr(itr, "(")
                If n > 0 Then 
                    nazw = Left(itr, n - 1)
                    While n < Len(itr) 
                        nz = nz + 1
                        Z = n + 1
                        n = InStr(Z, itr, ";")
                        If n = 0 Or nz = 3 Then n = Len(itr) 
                        bd(rd, csk + nz) = Mid(itr, Z, n - Z)   
                    Wend
                Else   
                    nazw = itr 
                End If
               bd(rd, csk) = nazw   
               sk = sk + 1 
            Wend
        End If
        rs = rs + 1
    Wend
    Debug.Print Timer - tt
    End Sub


    Docelowo jest też makro które robi to w odwrotną stronę czyli łączy podzielony wiersz z powrotem w jeden (wersja podzielona podawana jest dalej do programu, który generuje na tej podstawie dokumenty), wersja połączona wysyłana jest do zainteresowanych. I jest łatwiejsza do odczytania do wydruku

    Code:
    Sub nowy_stary()
    
    Dim bs As Range, bd As Range   
    With Sheets("nowy")
        ostw = .Cells(Rows.Count, 2).End(xlUp).Row
        Set bs = .Range(.Rows(3), .Rows(ostw)).Cells   
    End With
    Set bd = Sheets("stary").Cells 
    bd(1, 1).Resize(Rows.Count - 2, Columns.Count).ClearContents   
    rs = 1: rd = 1
    While rs <= bs.Rows.Count 
        If bs(rs, 2) <> vbNullString Then 
            bs(rs, 1).Resize(1, 2).Copy bd(rd, 1)   
            tras = vbNullString: sk = 0
            ks = 3 + sk * 4
            While bs(rs, ks) <> vbNullString   
                If sk > 0 Then tras = tras & "-"   
                tras = tras & bs(rs, ks)   
                szm = vbNullString 
                For zm = 3 To 1 Step -1
                    If bs(rs, ks + zm) <> vbNullString Then
                        szm = bs(rs, ks + zm) & szm
                    End If
                        If szm <> vbNullString And zm > 1 Then szm = ";" & szm
                Next    'zm
                If szm <> vbNullString Then szm = "(" & szm & ")" 
                tras = tras & szm 
                sk = sk + 1
                ks = 3 + sk * 4
            Wend 
            bd(rd, 3) = tras   
            rd = rd + 1
        End If
        rs = rs + 1
    Wend   
    End Sub


    Docelowo makro mogłoby wyglądać odpalic stary_nowy -> uruchomić makro o którym pisałem i odpalić nowy_stary. Pytanie tylko czy ktoś ma w programowaniu w VB na tyle tęgą głowę, że jest w stanie coś takiego wymyślić. Ja nie mam pojecia jak sie za to nawet zabrać. Z góry dziękuję za wszelkie odpowiedzi.
  • Poziom 37  
    Czy mógłbyś skrócić opis, bez kodu, do minimum?
  • Poziom 12  
    Po powrocie do domu zrobię taki testowy arkusz w którym będzie oznaczone o co mi chodzi.

    Dodano po 4 [godziny] 31 [minuty]:

    Także wygląda to tak.

    Arkusz1

    Wiersz 1 - tak wygladaja moje dane wejsciowe do których bym chciał dodać znaczniki (;?) (;?;) itp. Dlaczego sredniki? A to glownie po makro jezeli mialoby ono być wykorzystane (w arkuszu drugim jest rozpisane to samo jak wygladaloby po przemieleniu przez makro ktore napisał JRV. Przed i po średnikach może być tekst więc zależy mi aby te znaki zapytania leciały w odpowiednie miejsce w nawiasie a dokladnie między średnikami. Chociaz to jest sprawa raczej poboczna. Do ogarniecia poźniej.

    Z boku dopisana lista wyglada jak to co chce dopisac do mojej komorki (docelowo byłaby ona w innym pliku. Nazwa pliku stala i raczej niezmienna.

    Wiersz 7 to 'markowanie' miejsc w ktorych chciałbym przypisać wartości z listy z boku. Może sie pojawić, taki np 'xxx' pojawi sie kilka razy w innym wierszu. Stąd '(;?)' ktore ma pokazać excelowi gdzie konkretnie dla tego miejsca chce przypisac wartosci z pliku

    Wiersz 14 - wynik jakiego się spodziewam. I oznaczenia w pliku z którego pobierał wartości. To co jest 'dopisane' oznaczone kolorem nazwijmy to zielonym, to co jest, ale nie zostalo nigdzie znalezione w kolorze czerwonym, a gdziekolwiek indziej dopisane braki czyli jezeli oznaczylem wartość 'zzz' do dopisania wartosci z pliku, a ta nie została znaleziona.


    W arkuszu drugim jest caly czas to samo tylko jak wygladaloby po przemieleniu przez makro stary_nowy
  • Specjalista - VBA, Excel
    Ile znaków "?" maksymalnie może być w nawiasach?
    Tylko jeden? Zawsze jak 2 parameter?
    Wiersze nie będzie jeden. Dla każdego swoj zestaw?(np. 10, 5, 4, 8 dla 1 wiersza, 12, 3, 5, 7 dla 2 itd)
  • Poziom 12  
    Tak, '?' nie zdarza sie nigdy i nawet jezeli mialby sie zdarzyc mozna go latwo wyeliminowac.

    znak '?' to tylko przyklad. Chodzi o to ze jezeli bedzie przy danym rekordzie umówiony znak który normalnie się nie powtarza np xxx(abcd;?;asd) to ma to byc informacja dla excela że w pliku z lista ma wyszukac wlasnie 'xxx' w liscie i wpisac go jako drugi parametr czyli w zadanym miejscu.

    Sam znak ? sprawiałby, że decyzje gdzie przepisać wartości miałby ten kto chce je dodać, ale oszczedzalby mnostwo czasu wpisujac tylko '?' zamiast wyszukiwac w co raz to dluzszej liscie (aktualnie około 500 wierszy i co miesiac wiecej) odpowiedniego wiersza z odpowiednia wartoscia zostawic to skryptowi excela.

    Co do ilosci wierszy - wierszy w wersji pierwszej bedzie sporo więcej od 10-250 sam rekord xxx yyy zzz moze pojawiac sie wielokrotnie w roznych wierszach, ale zawsze ich wartosc bedzie taka sama (jedna wartosc dla jednego rekordu z listy 500 o ktorych mowilem wczesniej)


    Dlatego tez stosowanie znaku '?' jako markera bo na dobra sprawe wartosc z tego pliku ma byc dopisana tylko raz.

    wiec jezeli w pierwszym wierszu bedzie

    xxx-yyy-ccc

    w kolejnym

    xxx-zzz-aaa

    i w jeszcze kolejnym


    xxx-bbb-xxx

    i tylko w tym ostatnim bedzie to uzupelnione w sposob:

    xxx-bbb-xxx(;?)


    to z listy przeniesiona i przepisana zostanie wartosc (załóżmy 10) tylko na koncu

    xxx-bbb-xxx(;10)

    pozostałe dwa pozostaną też niezmienione.
  • Pomocny post
    Specjalista - VBA, Excel
    Code:

    Sub stary_nowy()
    Const mark = "?"    'tu dopasuj swoj marker np. "*", "#", "$"
    listpath = "D:\lista.xls"   'tu dopasuj sciezku do listy, oddzielny plik, tylko jeden arkusz
    Dim lista As Range
    With Workbooks.Open(listpath)
        Set lista = Sheets(1).Range("A:E").Cells
    End With
    lista(2, 2).Resize(Application.CountA(lista.Columns(1)) - 1).Interior.Color = vbRed
    ThisWorkbook.Activate
    tt = Timer
    Dim bs As Range, bd As Range
    Dim rs&, rd&, rl&
    With Sheets("stary")
        ostw = .Cells(Rows.Count, 3).End(xlUp).Row
        Set bs = .Range(.Cells(1, 1), .Cells(ostw, 3)).Cells
    End With
    Set bd = Sheets("nowy").Cells
    bd(3, 1).Resize(Rows.Count - 2, Columns.Count).ClearContents
    rs = 1: rd = 2
    While rs <= bs.Rows.Count
        If bs(rs, 3) <> vbNullString Then
            rd = rd + 1
            bs(rs, 1).Resize(1, 2).Copy bd(rd, 1)
            tras = Trim(bs(rs, 3))
            p = 0: sk = 0
            While p < Len(tras)
                csk = sk * 4 + 3
                p1 = p + 1
                p = InStr(p1, tras, "-")
                If p = 0 Then p = Len(tras) + 1
                itr = Trim(Mid(tras, p1, p - p1))
                nz = 0: z = 0
                n = InStr(itr, "(")
                If n > 0 Then
                    nazw = Left(itr, n - 1)
                    While n < Len(itr)
                        nz = nz + 1
                        z = n + 1
                        n = InStr(z, itr, ";")
                        If n = 0 Or nz = 3 Then n = Len(itr)
                        parm = Mid(itr, z, n - z)
                        bd(rd, csk + nz) = parm
                        If nz = 2 And Trim(parm) = mark Then
                            If Application.CountIf(lista.Columns(1), nazw) > 0 Then
                                rl = Application.Match(nazw, lista.Columns(1), 0)
                                bd(rd, csk + nz) = lista(rl, 2)
                                lista(rl, 2).Interior.Color = vbGreen
                            Else
                                If Application.CountIf(lista.Columns(4), nazw) = 0 Then
                                    rl = Application.CountA(lista.Columns(4)) + 1
                                    lista(rl, 4) = nazw
                                End If
                            End If
                        End If
                    Wend
                Else
                    nazw = itr
                End If
               bd(rd, csk) = nazw
               sk = sk + 1
            Wend
        End If
        rs = rs + 1
    Wend
    lista.Parent.Parent.Close True
    Debug.Print Timer - tt
    End Sub

    + nowy_stary a je to
  • Poziom 12  
    Dokładnie o to mi chodziło. Wielkie dzięki za pomoc.

    Sprawdzę jak to działa w praktyce z całością i wieczorem się odezwę

    Dodano po 4 [godziny] 13 [minuty]:

    Pytanie, czy ścieżkę dostępu można zmienić w inny sposób. Chciałbym wrzucić ten plik na nasz dysk Google. Więc ścieżka dostępu to C:/Users/Użytkownik1/Dysk Google/lista.xlsx. W momencie gdy inny użytkownik dysku na innym komputerze chce uruchomić makro wywala mu błąd, że ścieżka nie istnieje bo w jego przypadku ścieżka to C:/Users/Użytkownik2/Dysk Google/lista.xlsx

    Możnaby to trzymać na dysku offline i każdemu przesłać kopie i zmodyfikować ścieżkę tak żeby wszystkim pasowało, ale ten plik będzie z czasem uzupełniany więc zależy na tym aby wersje były identyczne u wszystkich.

    Co więcej. Nawet ja nie mogę uruchomić tego makra jeżeli lista.xls jest na dysku sieciowym otrzymuje błąd "Run-time error 1004 - Program Excel nie uzyskał dostępu do dokumentu 'Dysk Google' Dokument może być w trybie tylko do odczytu lub zaszyfrowany"

    Zmiana atyrbutów folderu w Windows też niewiele pomogła. Zauważyłem też, że lista.xls zamyka się bez pytania o np zapisanie zmiany na czas działania makra potem trzeba ją ręcznie uruchamiać.

    Co jeżeli zostawić by ją otwartą a zamiast podawania scieżki skorzystać z czegoś w stylu - Windows("lista.xls").Activate ?
  • Pomocny post
    Specjalista - VBA, Excel
    steelek56 napisał:
    Chciałbym wrzucić ten plik na nasz dysk Google

    Nic, co można powiedzieć. Nie używam dysk Google.
    steelek56 napisał:
    że lista.xls zamyka się bez pytania o np zapisanie zmiany

    Zmiany chranione po zamykani. Jak nie trzeba zamykac, usun to
    Code:
    lista.Parent.Parent.Close True
    steelek56 napisał:
    skorzystać z czegoś w stylu - Windows("lista.xls").Activate

    Aktywacja nie jest konieczna, tylko otwarty. Wtedy zamiast
    Code:
    With Workbooks.Open(listpath)
    
        Set lista = Sheets(1).Range("A:E").Cells
    End With
    wpisz
    Code:
    Set lista = Workbooks("lista.xls").Sheets(1).Range("A:E").Cells
  • Poziom 12  
    Teraz jest ok. Scieżka nie jest wymagana więc uruchomienie makra na komputerze przy innej sciezce pliku nie jest tez problemem.

    Co mi jednak wyskoczylo jeszcze to dwie rzeczy.

    Plik lista.xls zmodyfikowalem tak, aby dostosować go do własnych potrzeb. Przykładowy plik wrzuciłem w załącznik.

    Powstają dwa problemy:

    Pierwszy to fakt, że raport zwrotu pobierany jest z zewnętrznego narzędzia i dostarczany w formie pliku xls. 4 kolumny z których interesują mnie tylko 2. Plik wrzucony w arkusz Raport - 4 pierwsze kolumny. 2 kolejne to swego rodzaju 'konwersja' w stosunku raport, a to do czego te zwroty mają zostać dopisane. Sama konwersja jest banalna poprzez wykorzystanie Wyszukaj.Pionowo pobierajac dane z arkusza DBS. Problem robi się, gdy rozne osoby korzystajace z narzedzia roznie zapisuja nazwy rekordow. I tak nasze

    xxx-yyy-zzz-aaa-bbb-ccc

    moze byc przez inna osobe zapisane jako:

    xxx1-yyy-zzz1-aaa1-bbb1-ccc1

    Dlatego tez DBS zawiera obie wersje stosowane przez rozne osoby (to wciąż jest ten sam rekord po prostu inaczej zapisany). Ogólnie w raporcie nazwą sa nazwy miast. I tak ktoś zapisuje to jako 'Tarnowo Podgórne', ktoś inny jako 'Tarnowo Podg' a jeszcze ktoś jako 'Tarnowo Podg.'

    Wyszukując pionowo excel po znalezieniu w arkuszu raport punktu aaa w DBS zwraca ilość zwrotu z miejscowości aaa. Lecz jezeli ktoś zapisze ciąg jako:

    xxx1-yyy-zzz1-aaa1(;?)-bbb1-ccc1

    to makro zwróci, że zwrot z 'aaa' nie został przypisany (kolor czerwony) a w kolumnie D wpisze aaa1 jako brak w raporcie.

    Myślałem, aby to rozwiązać podobnie jak w DBS zrobiłem z 'yyy' czyli jeżeli ktoś zapisuje 'yyy', ktoś inny jako 'yyy1' a potem ktoś jako 'yyy 1' to każde kolejne wariacje na temat tego samego rekordu raportu wpisywac w kolejnej kolumnie tego samego wiersza (tych wersji zwykle nie jest wiecej niz 3-4 na dany rekord), ale aktualizujac plik o co raz to inne nazwy tego samego rekordu docelowo uzyskamy taki ktory pokrywa wersje nazewnictwa wszystkich uzytkowników.

    Wtedy niezaleznie od tego czy ktoś wpisze 'yyy(;?)' czy 'yyy 1(;?)' to wartość za znak zapytania zostanie zastąpiona wartością z raportu odpowiadajacej nazwie 'Ayyy1'

    Druga rzecz to, że cały skrypt dla jednego raportu chciałbym uruchamiać 4 razy (ciągi xxx-yyy-zzz... znajdują się w 4 różnych arkuszach). Ilość w arkuszach jest różna nigdy stała więc wrzucanie wszystkiego do jednego i potem dzielenie jest troche problematyczne. Napisałem proste makro, które wrzuca pierwszy arkusz, dopisuje zwroty z pliku lista, kopiuje wynik z powrotem do miejsca z ktorego zostalo pobrane, przeskakuje do arkusza2 robi to samo, potem arkusz 3 i arkusz 4. Za każdym razem makro jest jednak uruchamiane ponownie. I o ile działa to ok. O tyle wynik w lista.xls jest zakłamany. Komórki oznaczane są kolorem czerwonym jeżeli rekord z zapytaniem '?' nie został odnaleziony przy ostatnim uruchomieniu makro (arkusz4) a został przepisany w którymś z poprzednich (np odnaleziony i oznaczony na zielono przy przebiegu przez arkusz2).


    jeszcze jeden szczegół.

    Czy w pliku lista w Kolumnie C mogłaby się pojawiać liczba symbolizujaca ile razy dany rekord zostal odnaleziony i przypisany przy danym przebiegu makra? Docelowo chcemy aby to zostało przepisane tylko jeden raz, ale czasem przy długiej liscie może się zdarzyć, że '(;?)' zostanie dopisane dwa razy.

    Przykład

    wiersz 3 - xxx-yyy-zzz-aaa(;?)-bbb-ccc

    wiersz 150 - yyy-aaa(;?)


    wartosc z listy powinna przypisać się tylko raz. Wtedy kontrolując plik lista.xls i widząc przy rekordzie aaa liczbę 2 wiedziałbym, że ktoś popełnił błąd i ten sam rekord przypisał dwa razy (to który ma zostać faktycznie przypisany a który skasowany lepiej zostawić decyzji tego, kto uruchomił makro, nie można na to ustawić logicznej reguły)
  • Specjalista - VBA, Excel
    steelek56 napisał:
    ktoś zapisuje 'yyy', ktoś inny jako 'yyy1' a potem ktoś jako 'yyy 1'
    Niech nie pisać ręcznie, wybierz z listy
  • Poziom 12  
    Problem w tym, że ciągi są zapisywane ręcznie nie da się z listy wybrać kilku punktów w różnej kolejności tak aby zapisały sie w jednej komorce.

    Cos takiego robimy za pomocą formuły złącz.tekst. Każdy rekord w oddzielnej komórce a potem łączony do jednej. Z tym, że wypisywanie tych punktów lub wybieranie ich z rozwijanej listy trwa o wiele dluzej niz po prostu ich zapisanie.

    Zawsze pozostaje opcja wymuszenia jednej wersji