Uprava makra

[SeTH]

zdravim potreboval bcyh upravit vyhledavaci makro. urcite to bude neco jednoduchyho ale nevim kde to najit :)
makro fiunguje bezvadne ale potrebuju aby vyhledaval jenom v jednom sloupci a to ve sloupci E.
jedna se o upravene makro Turbofind, muze obsahovat chyby, protoze v VBA neovladam

Kód: Vybrat vše

Option Explicit
Sub vymeniky(FindText As String)

' vytvořil: Ladys.R@seznam.cz

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

ThisWorkbook.Sheets("Vypis").Range("A2:D1000").ClearContents

Dim SheetsAreas(100) As Worksheet
Dim A As Long, B As Long, i As Long, j As Long, k As Long
Dim PomAddress As String, PomAreas As String, HlinkAddress As String, Linkdisplay As String, NextAddress As String, NextCell As String

A = 0
B = 1

For i = 1 To ThisWorkbook.Sheets.Count - 1
    If Sheets(i).Name <> "Vypis" Then
        A = A + 1
        Set SheetsAreas(A) = Sheets(i)
    End If
Next i

For j = 1 To A

SheetsAreas(j).Activate
Range("A1").Activate
On Error Resume Next
Cells.Find(What:=FindText, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
        :=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
        False).Activate
        If Err = 0 Then
        B = B + 1
            PomAddress = ActiveCell.Address
            PomAreas = SheetsAreas(j).Name & PomAddress
            NextAddress = ActiveCell.Previous.Text
            If NextAddress = vbNullString Then
                NextAddress = ""
            Else
                NextAddress = NextAddress
            End If
           
            ThisWorkbook.Sheets("Vypis").Cells(B, 1).Value = _
            ThisWorkbook.Sheets(SheetsAreas(j).Name).Range(PomAddress).Value
            ThisWorkbook.Sheets("Vypis").Cells(B, 3).Value = SheetsAreas(j).Name
            ThisWorkbook.Sheets("Vypis").Cells(B, 2).Value = NextAddress
           
            HlinkAddress = SheetsAreas(j).Name & "!" & PomAddress
               
           
            ThisWorkbook.Sheets("Vypis").Hyperlinks.Add Anchor:=ThisWorkbook.Sheets("Vypis").Cells(B, 4), Address:="", SubAddress:= _
            HlinkAddress, TextToDisplay:="Jít na záznam"
                       
            For k = 1 To 100000
            On Error Resume Next
               
                Cells.FindNext(After:=ActiveCell).Activate
                PomAddress = ActiveCell.Address
                NextAddress = ActiveCell.Previous.Text
                If SheetsAreas(j).Name & PomAddress = PomAreas Then GoTo NextSheet
               
                If NextAddress = vbNullString Then
                    NextAddress = ""
                Else
                    NextAddress = NextAddress
                End If
               
                B = B + 1
                ThisWorkbook.Sheets("Vypis").Cells(B, 1).Value = _
                ThisWorkbook.Sheets(SheetsAreas(j).Name).Range(PomAddress).Value
                ThisWorkbook.Sheets("Vypis").Cells(B, 3).Value = SheetsAreas(j).Name
                ThisWorkbook.Sheets("Vypis").Cells(B, 2).Value = NextAddress
             
                HlinkAddress = SheetsAreas(j).Name & "!" & PomAddress
           
                ThisWorkbook.Sheets("Vypis").Hyperlinks.Add Anchor:=ThisWorkbook.Sheets("Vypis").Cells(B, 4), Address:="", SubAddress:= _
                HlinkAddress, TextToDisplay:="Jít na záznam"
       
               
               
            Next k
        End If
NextSheet:
       
Next j

Sheets("Vypis").Select
Application.Calculation = xlCalculationAutomatic
Application.Calculate

Application.ScreenUpdating = True

End Sub
Sub spustit_hledani()
    If Worksheets("Vypis").Range("f2") = vbNullString Then
        ThisWorkbook.Sheets("Vypis").Range("A2:D1000").ClearContents
    Else
        vymeniky Worksheets("Vypis").Range("f2")
    End If
End Sub


[Reklama]

[navstevnik]

Bohuzel cela programova konstrukce je trochu tezkopadna, takze uprava se neobejde bez vetsiho zasahu. A je daleho rychlejsi, nez analyzovat a upravovat nevhodne makro, napsat makro nove. Navic chybi jakakoliv presna specifikace toho, co ma makro vykonat.
V predchozim dotazu "Vyhledavani" jsi dostal vysledne makro napsane presne podle nekolikrat tebou upresnovanych pozadavku a nakonec jsi od jeho pouziti ustupil a rozhodl ses pouzit makro, ktere nyni pozadujes upravit a to na vyhledavani ve sloupci E.

[SeTH]

no predstavoval jsme si to tak ze se tam jenom nekde prepise aby vyhledaval jen v urcitem sloupci na misto celyho listu...

[SeTH]

A bylo by mozny to makro poupravit ab vyhledaval jenom ve sloupci E pro kazdy list a nme v celekm listu..?

[mike007]

Plně souhlasím s navstevnikem. Makro by se muselo kompletně předělat. Nejde mi do hlavy, proč nevyužiješ makra, které ti napsal ...? Vždyť splňuje všechny tvoje požadavky ...