Ani toto?
If xAddress = Range("List1!AA1") Thencitovat
If xAddress = Range("List1!AA1") Thencitovat
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: Velikosti objektů na základě hodnoty v buňce
MS Excel
Téma: Velikosti objektů na základě hodnoty v buňce 
Zaslal/a 10.9.2018 15:37
Ahoj všichni,
prosím o radu. Snažím se vymyslet makro na změnu velikosti objektů na základě hodnot v buňkách. Dal jsem do kupy níže uvedené makro, které částečně funguje - mění velikosti objektů (Ovál 42 až 43) na základě vložení hodnot do buněk AA1 až AG1. Problém ale je, že se makro spustí pouze v případě manuálního vložení hodnoty do některé z výše uvedených buněk. Jenže buňky AA1 až AG1 jsou počítány vzorci a já potřebuji, aby se makro spouštělo na základě změny hodnoty v buňce A1 nebo A2, kam se zadává časové rozpětí. Žádné jiné buňky se manuálně měnit nebudou. Můžete prosím poradit?
Private Sub Worksheet_Change(ByVal Target As Range)
Dim xAddress As String
On Error Resume Next
If Target.CountLarge = 1 Then
xAddress = Target.Address(0, 0)
If xAddress = "AA1" Then
Call SizeCircle("Ovál 42", Val(Target.Value))
ElseIf xAddress = "AB1" Then
Call SizeCircle("Ovál 43", Val(Target.Value))
ElseIf xAddress = "AC1" Then
Call SizeCircle("Ovál 44", Val(Target.Value))
ElseIf xAddress = "AD1" Then
Call SizeCircle("Ovál 45", Val(Target.Value))
ElseIf xAddress = "AE1" Then
Call SizeCircle("Ovál 46", Val(Target.Value))
ElseIf xAddress = "AF1" Then
Call SizeCircle("Ovál 47", Val(Target.Value))
ElseIf xAddress = "AG1" Then
Call SizeCircle("Ovál 48", Val(Target.Value))
End If
End If
End Sub
Sub SizeCircle(Name As String, Diameter)
Dim xCenterX As Single
Dim xCenterY As Single
Dim xCircle As Shape
Dim xDiameter As Single
On Error GoTo ExitSub
xDiameter = Diameter
If xDiameter > 100 Then xDiameter = 10
If xDiameter < 1 Then xDiameter = 1
Set xCircle = ActiveSheet.Shapes(Name)
With xCircle
xCenterX = .Left + (.Width / 2)
xCenterY = .Top + (.Height / 2)
.Width = xDiameter
.Height = xDiameter
.Left = xCenterX - (.Width / 2)
.Top = xCenterY - (.Height / 2)
End With
ExitSub:
End Sub
Dále mě zajímá, jak v makru odkazovat na buňku v jiném listu. Následující kód nefunguje:
If xAddress = "List1!AA1" Then
Moc prosím o radu.
Děkuji
Šmarjá, čo je to zas za požiadavku bez prílohy ? Príklad (potrebujete uchovávať staré hodnoty), kde je to volané podľa zmeny A2:A3. Dá sa to ale urobiť aj na metódu Calculate, ale takto to bude asi lepšie.
Private Sub Worksheet_Change(ByVal Target As Range)
Dim V(), O(), x As Byte
If Not Intersect(Cells(2, 1).Resize(2), Target) Is Nothing Then
ReDim V(1 To 1, 1 To 7): ReDim O(1 To 1, 1 To 7)
V = Cells(2, 27).Resize(1, 7).Value
O = Cells(1, 27).Resize(1, 7).Value
Application.ScreenUpdating = False
For x = 1 To 7
If V(1, x) <> O(1, x) Then Call SizeCircle(Shapes("Ovál " & 41 + x), V(1, x))
Next x
Application.EnableEvents = False
Cells(1, 27).Resize(, 7).Value = V
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Sub SizeCircle(ByRef xCircle As Shape, Diameter)
Dim PozW As Single, PozH As Single, PolD As Single
Diameter = IIf(Diameter > 100, 10, IIf(Diameter < 1, 1, Diameter))
With xCircle
PozW = .Left + .Width / 2
PozH = .Top + .Height / 2
PolD = Diameter / 2
.Width = Diameter
.Height = Diameter
.Left = PozW - PolD
.Top = PozH - PolD
End With
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim V(), O(), x As Byte
If Not Intersect(Cells(2, 1).Resize(2), Target) Is Nothing Then
ReDim V(1 To 1, 1 To 7): ReDim O(1 To 1, 1 To 7)
V = Cells(2, 27).Resize(1, 7).Value
O = Cells(1, 27).Resize(1, 7).Value
Application.ScreenUpdating = False
For x = 1 To 7
If V(1, x) <> O(1, x) Then Call SizeCircle(Shapes("Ovál " & 41 + x), V(1, x))
Next x
Application.EnableEvents = False
Cells(1, 27).Resize(, 7).Value = V
Application.EnableEvents = True
Application.ScreenUpdating = True
End If
End Sub
Sub SizeCircle(ByRef xCircle As Shape, Diameter)
Dim PozW As Single, PozH As Single, PolD As Single
Diameter = IIf(Diameter > 100, 10, IIf(Diameter < 1, 1, Diameter))
With xCircle
PozW = .Left + .Width / 2
PozH = .Top + .Height / 2
PolD = Diameter / 2
.Width = Diameter
.Height = Diameter
.Left = PozW - PolD
.Top = PozH - PolD
End With
End Sub
Příloha: 
41463_zmena-shapes-podla-hodnt-vzorca.zip (19kB, staženo 17x)
citovat41463_zmena-shapes-podla-hodnt-vzorca.zip (19kB, staženo 17x)Elninoslov díky za radu (jsem autor tohoto článku), bohužel to nefunguje tak jak bych potřeboval. Upravil jsem proto svůj reálný soubor tak aby odpovídal tomu co potřebuji - viz příloha.
V listu Overiew jsou objekty, která by měly měnit velikost podle buněk na listu Calculations!B21-H23 viz VBA kód na listu Overview.
Problém je, že uvedené buňky se vypočítávají pomocí vzorů a jejich změna tak nespouští makro. Makro by se mělo spustit při změně hodnoty v buňce Overview!D3 nebo Overview!F3. To jsou jediné buňky, které bude uživatel manuálně měnit.
Můžete prosím poradit?
EDIT: Nedaří se mi nahrát přílohu, tak posílám link: http://leteckaposta.cz/463009180citovat
V listu Overiew jsou objekty, která by měly měnit velikost podle buněk na listu Calculations!B21-H23 viz VBA kód na listu Overview.
Problém je, že uvedené buňky se vypočítávají pomocí vzorů a jejich změna tak nespouští makro. Makro by se mělo spustit při změně hodnoty v buňce Overview!D3 nebo Overview!F3. To jsou jediné buňky, které bude uživatel manuálně měnit.
Můžete prosím poradit?
EDIT: Nedaří se mi nahrát přílohu, tak posílám link: http://leteckaposta.cz/463009180citovat
Sub Aktualizuj()
Dim V(), O(), x As Byte, y As Byte
ReDim V(1 To 3, 1 To 7): ReDim O(1 To 3, 1 To 7)
V = List3.Cells(21, 2).Resize(3, 7).Value
O = List3.Cells(24, 2).Resize(3, 7).Value
Application.ScreenUpdating = False
For y = 1 To 3
For x = 1 To 7
If V(y, x) <> O(y, x) Then Call SizeCircle(List1.Shapes("Ovál " & 42 + x + ((y - 1) * 7)), V(y, x))
Next x
Next y
List3.Cells(24, 2).Resize(3, 7).Value = V
Application.ScreenUpdating = True
End Sub
Ja by som to nerobil ako reakciu na prepočet buniek, ale ako reakciu na zmenu toho, čo prepočet spôsobuje. A to je zmena D3 alebo F3 alebo zmena vstupných dát. D3 a F3 odchytajte cez
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("D3,F3"), Target) Is Nothing Then Aktualizuj
End Sub
a prípadnú zmenu zdrojových údajov predsa musíte robiť keď ste na tom liste samsung-svc-report. Teda odchyťte odchod z tohto listu pri ktorom sa zavolá prekreslenie Shapes
Private Sub Worksheet_Deactivate()
Aktualizuj
End Sub
Ďalej neprekresľujte tie, ktoré sa nezmenili. Na to je tam uchovanie starých hodnôt. Môžete použiť buď moju SizeCircle alebo Vašu SizeCircle2 (len som upravil xCircle na objekt).
Sub SizeCircle(ByRef xCircle As Shape, Diameter)
Dim PozW As Single, PozH As Single, PolD As Single
Diameter = IIf(Diameter > 100, 10, IIf(Diameter < 1, 1, Diameter))
PolD = Diameter / 2
With xCircle
PozW = .Left + .Width / 2
PozH = .Top + .Height / 2
.Width = Diameter
.Height = Diameter
.Left = PozW - PolD
.Top = PozH - PolD
End With
End Sub
alebo
Sub SizeCircle2(ByRef xCircle As Shape, Diameter)
Dim xCenterX As Single
Dim xCenterY As Single
Dim xDiameter As Single
On Error GoTo ExitSub
xDiameter = Diameter
If xDiameter > 100 Then xDiameter = 100
If xDiameter < 1 Then xDiameter = 1
With xCircle
xCenterX = .Left + (.Width / 2)
xCenterY = .Top + (.Height / 2)
.Width = xDiameter
.Height = xDiameter
.Left = xCenterX - (.Width / 2)
.Top = xCenterY - (.Height / 2)
End With
ExitSub:
End Sub
Ak ale chcete, tak to kľudne zavolajte aj cez Worksheet_Calculate listu Calculations, len pri prípadnej zmene zdroju, to bude prekresľovať pri zmene každej oblasti. V tom prípade ale vymažte Worksheet_Change z listu Overview a Worksheet_Deactivate z listu samsung-svc-report.
Private Sub Worksheet_Calculate()
Aktualizuj
End Sub
Funguje to na obidva spôsoby. Ešte som Vám upravil vzorce v Calculations:
A11 - "rrrr" pozná iba CZ Excel, ostatné nie
B21:H23 - Pridal som IFFERROR, lebo pri zmene dátumov na rovnaký 1.9.2018 prichádza k deleniu nulou.
A ešte som zmenil číslovanie Shapes zo 42-48 na 43-49, aby išli všetky po sebe (lebo ďalšie boli od 50...) a dal sa ľahko v cykle vypočítať názov. Inak by tam musela byť zbytočná podmienka.
Celé riešenie v prílohe na GoogleDrive.citovat
Dim V(), O(), x As Byte, y As Byte
ReDim V(1 To 3, 1 To 7): ReDim O(1 To 3, 1 To 7)
V = List3.Cells(21, 2).Resize(3, 7).Value
O = List3.Cells(24, 2).Resize(3, 7).Value
Application.ScreenUpdating = False
For y = 1 To 3
For x = 1 To 7
If V(y, x) <> O(y, x) Then Call SizeCircle(List1.Shapes("Ovál " & 42 + x + ((y - 1) * 7)), V(y, x))
Next x
Next y
List3.Cells(24, 2).Resize(3, 7).Value = V
Application.ScreenUpdating = True
End Sub
Ja by som to nerobil ako reakciu na prepočet buniek, ale ako reakciu na zmenu toho, čo prepočet spôsobuje. A to je zmena D3 alebo F3 alebo zmena vstupných dát. D3 a F3 odchytajte cez
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("D3,F3"), Target) Is Nothing Then Aktualizuj
End Sub
a prípadnú zmenu zdrojových údajov predsa musíte robiť keď ste na tom liste samsung-svc-report. Teda odchyťte odchod z tohto listu pri ktorom sa zavolá prekreslenie Shapes
Private Sub Worksheet_Deactivate()
Aktualizuj
End Sub
Ďalej neprekresľujte tie, ktoré sa nezmenili. Na to je tam uchovanie starých hodnôt. Môžete použiť buď moju SizeCircle alebo Vašu SizeCircle2 (len som upravil xCircle na objekt).
Sub SizeCircle(ByRef xCircle As Shape, Diameter)
Dim PozW As Single, PozH As Single, PolD As Single
Diameter = IIf(Diameter > 100, 10, IIf(Diameter < 1, 1, Diameter))
PolD = Diameter / 2
With xCircle
PozW = .Left + .Width / 2
PozH = .Top + .Height / 2
.Width = Diameter
.Height = Diameter
.Left = PozW - PolD
.Top = PozH - PolD
End With
End Sub
alebo
Sub SizeCircle2(ByRef xCircle As Shape, Diameter)
Dim xCenterX As Single
Dim xCenterY As Single
Dim xDiameter As Single
On Error GoTo ExitSub
xDiameter = Diameter
If xDiameter > 100 Then xDiameter = 100
If xDiameter < 1 Then xDiameter = 1
With xCircle
xCenterX = .Left + (.Width / 2)
xCenterY = .Top + (.Height / 2)
.Width = xDiameter
.Height = xDiameter
.Left = xCenterX - (.Width / 2)
.Top = xCenterY - (.Height / 2)
End With
ExitSub:
End Sub
Ak ale chcete, tak to kľudne zavolajte aj cez Worksheet_Calculate listu Calculations, len pri prípadnej zmene zdroju, to bude prekresľovať pri zmene každej oblasti. V tom prípade ale vymažte Worksheet_Change z listu Overview a Worksheet_Deactivate z listu samsung-svc-report.
Private Sub Worksheet_Calculate()
Aktualizuj
End Sub
Funguje to na obidva spôsoby. Ešte som Vám upravil vzorce v Calculations:
A11 - "rrrr" pozná iba CZ Excel, ostatné nie
B21:H23 - Pridal som IFFERROR, lebo pri zmene dátumov na rovnaký 1.9.2018 prichádza k deleniu nulou.
A ešte som zmenil číslovanie Shapes zo 42-48 na 43-49, aby išli všetky po sebe (lebo ďalšie boli od 50...) a dal sa ľahko v cykle vypočítať názov. Inak by tam musela byť zbytočná podmienka.
Celé riešenie v prílohe na GoogleDrive.citovat
(11.9.2018 14:09)#041473
Výborně, funguje to a já jsem Vaším dlužníkem. Až budu mít trochu času tak si projdu řešení a snad to pochopím.citovat
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