Excel - vyhledani a zobrazeni v MsgBox Vyřešeno

[jiri255]

Zdravím,
řeším už nějakou dobu problém v excelu s vyhledáním dat a jejich vypsáním do MsgBoxu,
ale nemůžu přijít na to, jak to udělat.
Mám list4 a v něm jsou ve sloupci D2 až D7 kody

Kód: Vybrat vše

   A         B         C        D         E           F         G        H
1
2                               kod        e          f         g        h
3                               456      test       test      test      test
4                               455      test1      test1     test1     test1 
5                               454      test2      test2     test2     test2
6                               453      test3      test3     test3     test3
7


a každý kód má na listu5 viz níže, pod sebou detail a já bych potřeboval ten detail pod kódem
zobrazit v MsgBoxu
Detail např. pro kód 454 je řádek 2 a 3 a detail pro kód 456 je řádek 5,6 a 7 atd.
Jinak kódů na listu4 může být několik řádků a na listu5 je spousta kódů s detaily

Kód: Vybrat vše

      A     B      C      D      E
1    454   test2 test2  test2   test2
2  457864  <<<   wee    7785    adsas
3  457865  <<<   ew     7786    adsas
4    456   test  test   test    test
5  566338  <<<   ssd    879870  sasd
6  566339  <<<   eww    879871  sasd
7  566340  <<<   ee     879872  sasd
8    453   test3 test3  test3   test3
9  32574   <<<   gcg    6214    hghv
10  455   test1  test1  test1   test1
11 7811    <<<   arr      44    ewsd
12 7812    <<<   asas     45    ewsd


Mělo by to fungovat, tak že když na listu4 klepnu třeba na kod 455, tak to v listu5 najde řádek
s kódem 455 a vše pod ním až po další řádek s dalším kódem to zobrazí v MsgBoxu, ty šipky
ve sloupci B ty vždy určují, že se jedná o detail pod každým řádkem a jsou u všech kódů stejné
a detailů pro jeden kód může být 1 až 40.
Chtěl jsem použít funkci SVYHLEDAT jenže ta by našla na listu5 kód pokud by byli seřazeny zasebou a to nikdy
nebudou, takže ji nejspíš nejde použít, pak jsem si říkal udělat to nějakým makrem, ale nevím jak na to
a pak taky, jak navázat makro na buňku nebo text v buňce nebo jak svázat hypertextový odkaz s makrem
jestli vůbec něco takového jde?
Nenapadá mě, jak to udělat, tak bych chtěl někoho požádat o radu.
Předem děkuji za případnou pomoc.

[Reklama]

[pavel.lasak]

kódy 455, 454 jsou na listu5 jedinečné? neopakují se? Pak lze použít SVYHLEDAT s nastavením typ 0 (přesná shoda).

Klik například přes údalost listu "SelectionChange " - http://office.lasakovi.com/excel/vba-li ... ost-listu/

MsgBox zobrazeni: http://office.lasakovi.com/excel/vba-fo ... no-msgbox/

[jiri255]

ano kódy na listu4 jsou na listu5 jedinečné a neopakují se. To SVYHLEDAT s typem 0 je dobrá věc to jsem nevěděl děkuji to se mi bude hodit.
Zkoušel jsem to nějak dát dohromady, ale myslím, že s tím svyhledat to nepůjde.
Našel jsem toto makro, které dokáže podle podmínky najít řádek a smazat ho, to mazání se mi nehodí místo toho jsem to chtěl
upravit pro ten MsgBox, ale vypíše mi to jen "true", že to našlo kód.
Nevěděl by někdo jak ho upravit, aby to zobrazilo ty řádky se šipkama pod nalezeným řádkem s kódem
a jak to hledání měnit místo 455 co je tam teď na odkaz na buňku?

Kód: Vybrat vše

Sub najit()

Sheets("list5").Select
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
Dim Kde As Integer


With Application
    CalcMode = .Calculation
    .Calculation = xlCalculationManual
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
    .DisplayPageBreaks = False

Firstrow = .UsedRange.Cells(1).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

For Lrow = Lastrow To Firstrow Step -1

With .Cells(Lrow, "A") ' Sloupec s hledanými podmínkami
If Not IsError(.Value) Then

On Error Resume Next
Kde = WorksheetFunction.Search("455", .Value, 1) 'zde by bylo potreba doplnit odkaz na bunku misto hodnoty
If Err.Number = 0 Then
 '.EntireRow.Delete  'podmínka v uvozovkách najde a odstrani radek (puvodni funkce)
 .EntireRow.Selection  'upraveno to delete
 MsgBox (.Select)   'pokus o doplneni MsgBoxu
End If
Err.Clear


End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.Calculation = CalcMode
End With
End Sub


To spouštění makra se mi podařilo vymyslet tak, že jsem použil tlačítko activex a do něj zadal místo popisu
odkaz na buňku, takže se mi v tom tlačítku zobrazí kód co je napsaný v buňce D3 a tím bych měl aktivní text v buňce,
ale jako i makro výše, má to problém, že je toprůhledné, takže když to tlačítko posunu nad buňku D3,
tak se mi ty dvě čísla překrývají a text(kód) v tom tlačítku je nečitelný.
Přikládám i excel k prohlédnutí a odzkoušení.

msgbox.xlsm

(26.19 KiB) Staženo 38 x

[cmuch]

Jako něco takového?, toto vlož do toho svého makra

Kód: Vybrat vše

If Err.Number = 0 Then
 Do While .Cells(Kde, 1).Offset(1, 1) = "<<<"  ' Inner loop.
        msgText = msgText & Chr(10) & .Cells(Kde, 1).Offset(1, 1).Address
        Kde = Kde + 1
 Loop
 .EntireRow.Selection 'upraveno to delete
 MsgBox (msgText)   'pokus o doplneni MsgBoxu
End If

[jiri255]

děkuji za pomoc, téměř to funguje, tak jak bych potřeboval najde to ty dva řádky pod tím
kódem např: 455 jen to do MsgBoxu nevypíše ten text na řádcích
7811 <<< arr 44 ewsd
7812 <<< asas 45 ewsd
ale zobrazí to
$B$11
$B$12
což jsou ty správně nalezené řádky šlo by to ještě poupravit, aby to zobrazilo ten text v nalezeném
řádku

A ještě dotaz jak místo té podmínky hledání "455" zapsat buňku, ze které si to tu podmínku číslo kódu
vezme?

[cmuch]

Tak pak takto

Kód: Vybrat vše

Sub najit()

 Dim Firstrow As Long, Lastrow As Long, Lrow As Long
 Dim Kde As Integer
 Dim c As Range
 Dim msgText As String, msgTextTmp As String
 Dim CoHledat As String

 CoHledat = "455"

 Sheets("list5").Select
 With ActiveSheet

    Firstrow = .UsedRange.Cells(1).Row
    Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row

    For Lrow = Lastrow To Firstrow Step -1
        With .Cells(Lrow, "A") ' Sloupec s hledanými podmínkami
            If Not IsError(.Value) Then
                On Error Resume Next
                Kde = WorksheetFunction.Search(CoHledat, .Value, 1)
                If Err.Number = 0 Then
                    Do While .Cells(Kde, 1).Offset(1, 1) = "<<<"  ' Inner loop.
                        For Each c In Range(.Cells(Kde, 1).Offset(1, 0).Address & ":" & .Cells(Kde, 1).Offset(1, 5).Address) '.Address
                            msgTextTmp = msgTextTmp & vbTab & c.Value
                        Next c
                        msgText = msgText & Chr(10) & msgTextTmp
                        Kde = Kde + 1
                        msgTextTmp = ""
                    Loop
                    MsgBox (msgText) 'MsgBox s hodnotami
                End If
                Err.Clear
            End If
        End With
    Next Lrow
 End With
End Sub


Záleží jak chceš makro spouštět, když to budeš vědět tak pak můžeš místo proměnné "CoHledat" dát svoji hodnotu po tvém spuštění.

[jiri255]

supéér díky, díky, díky to je přesně ono... funguje skvěle ještě jednou moc díky.