Hodil by se příklad.
E=1,2,3 / Q,W
F=7,8,9 / W,R,T
G=?
Jinak myslím, že něco podobného už tady párkrát bylo.
M@citovat
E=1,2,3 / Q,W
F=7,8,9 / W,R,T
G=?
Jinak myslím, že něco podobného už tady párkrát bylo.
M@citovat
excel, návod, tipy, funkce, makra, vba, tabulky, šablony
Váš průvodce programem Microsoft Excel a programováním maker ve VBA
< návrat zpět
Téma: Makro - podmínka hledání
Obecná diskuse
Téma: Makro - podmínka hledání 
Zaslal/a 11.7.2012 23:35
Dobrý den,chtěla bych poprosit o radu někoho zkušeného, zda by poradil s problémem. Jedná se o to, že bych potřebovala udělat makro, které má dělat následující akce: v sešitu mám celkem tři listy (list1, list2, list3).Na listu1 mám všechny data ve třech sloupcích, kdy ve sloupci A je hodnota E,F,G v rozevíracím seznamu. Každý sloupec má rozevírací seznam. Sloupec B má hodnoty 1 až 9 v rozevíracím seznamu.Sloupec C má hodnoty v rozevíracím seznamu Q,W, R, T.
Potřebuji udělat makro, když ve sloupci A se objeví písmeno E, tak aby se v rolovacím seznamu ve sloupci B objevily jenom hodnoty 1,2,3 a zaroveň ve slouci C hodnota Q,W v rozvíracím seznamu.
Podobně, když ve slouci A bude hodnota F, tak aby se v rozevíracím seznamu ve sloupci B objevily pouze hodnoty 7,8,9 a zaroveň ve slouci C v rozevíracím seznamu hodnoty W,R,T.
(12.7.2012 14:53)#008999
(12.7.2012 22:55)#009002
Taky si to myslím,jen nic nemohu k tomu najít´. Potřebuji to udělat jako spouštěcí makro nebo alespoň jako funkci, jsem v koncích a nic mě nejde,poradí me někdo? Děkuji.
citovat
citovat(13.7.2012 9:01)#009004
Třeba pomůže :-)
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Row > 1 Then
Dim podminka1, podminka2 As String
Select Case Target.Value
Case Is = "E"
podminka1 = "1,2,3"
podminka2 = "Q,W"
Case Is = "F"
podminka1 = "7,8,9"
podminka2 = "W,R,T"
Case Is = "G"
podminka1 = "4,5,6"
podminka2 = "R,T"
End Select
If podminka1 <> "" Then
With Range("B" & Target.Row).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=podminka1
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
If podminka2 <> "" Then
With Range("C" & Target.Row).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=podminka2
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End If
End Sub
M@citovat
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 1 And Target.Row > 1 Then
Dim podminka1, podminka2 As String
Select Case Target.Value
Case Is = "E"
podminka1 = "1,2,3"
podminka2 = "Q,W"
Case Is = "F"
podminka1 = "7,8,9"
podminka2 = "W,R,T"
Case Is = "G"
podminka1 = "4,5,6"
podminka2 = "R,T"
End Select
If podminka1 <> "" Then
With Range("B" & Target.Row).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=podminka1
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
If podminka2 <> "" Then
With Range("C" & Target.Row).Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=podminka2
.IgnoreBlank = True
.InCellDropdown = True
.InputTitle = ""
.ErrorTitle = ""
.InputMessage = ""
.ErrorMessage = ""
.ShowInput = True
.ShowError = True
End With
End If
End If
End Sub
M@citovat
Nebo třeba takto. V mem připadě při změně nebo přidani nových údaju pro rozeviraci seznamy neni nutne upravovat kod. Jedna připominka, je to vytvořeno pro excel 2010, pokud by to mělo pracovat v excel 2003, tak by se musel upravit vzorec pro pojmenovanou oblast.
Příloha: 
9008_podminka-hledani.zip (22kB, staženo 38x)
citovat9008_podminka-hledani.zip (22kB, staženo 38x)Uživatelské menu
Nejste přihlášen(a)
\n
\nMenu
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
Helios iNuvio
Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.
RSS nejnovější články