< návrat zpět

MS Excel


Téma: SVYHLEDAT přes VBA rss

Zaslal/a 3.7.2020 20:25

lugrDobrý den,

nevíte někdo jak lze jednoduše využít funkci SVYHLEDAT přes VBA? Když do sloupce C na Listu1 napíšu hodnotu makro najde na Listu2 výsledek a zapíše.

V příloze jsem to zatím nahradil vzorcem.

Příloha: zip47142_svyhledat_vba.zip (14kB, staženo 5x)
Zaslat odpověď >

#047144
avatar
A dôvod je aký?citovat
#047146
lugr
Taký, že nemůžu mít ve formuláři vzorce.citovat
#047164
elninoslov
2 varianty:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range, Are As Range, Kde(), H(), i As Long

Set Zmena = Intersect(Cells(2, 2).Resize(Rows.Count - 1), Target)
If Zmena Is Nothing Then Exit Sub
Kde = Worksheets("List2").Range("B2:C27").Value

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next
For Each Are In Zmena.Areas
With Are
H = .Value
For i = 1 To UBound(H, 1)
H(i, 1) = WorksheetFunction.VLookup(H(i, 1), Kde, 2, False)
If Err.Number <> 0 Then H(i, 1) = Empty: Err.Clear
Next i

.Offset(0, 1).Value = H
End With
Next Are

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range

Set Zmena = Intersect(Cells(2, 2).Resize(Rows.Count - 1), Target)
If Zmena Is Nothing Then Exit Sub

With Zmena.Offset(0, 1)
Application.ScreenUpdating = False
Application.EnableEvents = False

.Formula = "=IFERROR(VLOOKUP(B" & Zmena.Row & ",List2!$B$2:$C$27,2,FALSE),"""")"
.Value = .Value

Application.ScreenUpdating = True
Application.EnableEvents = True
End With
End Sub
citovat
#047165
lugr
Vyzkoušel jsem obě varianty a něco dělám špatně.

Vložil jsem Vaše makro do module, ale nefunguje mi to.
Příloha: zip47165_svyhledat_vba.zip (31kB, staženo 1x)
citovat
#047166
elninoslov
To musí isť do modulu listu, nie do normálneho modulu. Robil som to tak, aby to zvládlo viacnásobné zmeny, a tak som to aj testoval, ale netestoval som zmenu 1 bunky. Inak by ma trklo, že treba vo verzii 1 doplniť jednoprvkové pole. Takže upravené.
Vo verzii 2 by mohol nastať v špecifickom prípade kopírovania do multioblasti nesprávny výsledok. Išlo o to, že ak by ste skopíroval 2 bunky, a na vloženie by ste označil jednu 2 bunkovú oblasť a o niečo ďalej druhú 1 bunkovú oblasť, Excel automaticky vyplní aj tú jednobunkovú kópiou zdrojovej dvojbunkovej. A tá druhá vrátila zlý výsledok. To si musíte vyskúšať. Opravené.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range, Are As Range, Kde(), H(), i As Long

Set Zmena = Intersect(Cells(2, 2).Resize(Rows.Count - 1), Target)
If Zmena Is Nothing Then Exit Sub
Kde = Worksheets("List2").Range("B2:C27").Value

Application.ScreenUpdating = False
Application.EnableEvents = False

On Error Resume Next
For Each Are In Zmena.Areas
With Are
If .Rows.Count = 1 Then ReDim H(1 To 1, 1 To 1): H(1, 1) = .Value Else H = .Value
For i = 1 To UBound(H, 1)
H(i, 1) = WorksheetFunction.VLookup(H(i, 1), Kde, 2, False)
If Err.Number <> 0 Then H(i, 1) = Empty: Err.Clear
Next i

.Offset(0, 1).Value = H
End With
Next Are

Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub


Private Sub Worksheet_Change(ByVal Target As Range)
Dim Zmena As Range, Are As Range

Set Zmena = Intersect(Cells(2, 2).Resize(Rows.Count - 1), Target)
If Zmena Is Nothing Then Exit Sub

With Zmena.Offset(0, 1)
Application.ScreenUpdating = False
Application.EnableEvents = False

.Formula = "=IFERROR(VLOOKUP(B" & Zmena.Row & ",List2!$B$2:$C$27,2,FALSE),"""")"
For Each Are In .Areas
Are.Value = Are.Value
Next Are
Application.ScreenUpdating = True
Application.EnableEvents = True
End With
End Sub
Příloha: zip47166_vlookup_vba.zip (33kB, staženo 3x)
citovat
#047167
lugr
Je to super, jako vždy. Moc děkuji.citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

On-line nástroje

Formulář Faktura

Formulář Faktura III

Oblíbený formulář Faktura byl vylepšen a rozšířen. Formulář faktura III
Více se dočtete zde.

Aktivní diskuse

zavření souboru z VBA makra bez uložení

Lukas-nevimto • 3.8. 20:24

Zobrazení obrázku v Excelu

JoKe • 3.8. 19:46

Tisk s podmínkou

Jiří497 • 3.8. 15:57

blokovanie excelu

eLCHa • 3.8. 15:15

blokovanie excelu

fiala2503 • 3.8. 15:07

blokovanie excelu

eLCHa • 3.8. 14:29

Tisk s podmínkou

elninoslov • 3.8. 13:54