Příspěvky uživatele
< návrat zpět
Riešení je množstvo, napr.:
If Not Sh.Name = "udaje" and Not Sh.Name = "iný list" Then
If IsError(Application.Match(Sh.Name, Array("údaje", "iný list"), 0)) Then
If InStr(1, Join(Array("", "údaje", "iný list", ""), "•"), "•" & Sh.Name & "•", vbTextCompare) = 0 Then
Toto Vám bude prenášať aj hodnoty z prípadných viac buniek v riadku. Berie sa do úvahy 1. riadok 1. označenej oblasti. Preklopí ju na stĺpec a zapíše na správne miesto. Len nerozumiem, načo tam v 2 stĺpcoch mažete nasledujúcu hodnotu a v 2 nie. To tak má určite byť ? Ak áno tak to urobíme inak.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim rngVyber As Range
Set rngVyber = Intersect(Range("F2:I7"), Target.Rows(1))
If Not rngVyber Is Nothing Then Cells(2, 4).Resize(rngVyber.Columns.Count).Offset(rngVyber.Column - 6).Value = WorksheetFunction.Transpose(rngVyber)
End Sub
Tie ďalšie dve makrá zjednodušte napr. takto:
Sub Makro1()
With ActiveSheet.Range("K1:K6").Interior
.Pattern = xlNone
.TintAndShade = 0
.PatternTintAndShade = 0
End With
End Sub
Sub Makro2()
ActiveSheet.Range("F1").Copy ActiveSheet.Range("D1")
'alebo ak nepotrebujete prenášať formátovanie bunky tak stačí:
'ActiveSheet.Range("D1") = ActiveSheet.Range("F1")
End Sub
Teda všetko iba v prípade ak Vás chápem správne.
No keď Vám nejaká medzera nemizne, tak si otestujte či je to medzera
=CODE(MID(A1;2;1))
A1 - text
2 - číslo znaku (ten, ktorý by mal zmiznúť a nemizne)
1 - počet znakov (to musí byť logicky 1)
Funkcia Vám vráti ASCII hodnotu daného znaku. Normálna medzera má ASCII hodnotu 32. Táto tzv. "pevná medzera" má ASCII hodnotu 160. Napíšete ju aj ručne ak podržíte ľavý Alt a napíšete 0160. Používa sa na účel vyplývajúci z jej názvu najmä na webe.
Ten predošlý vzorec urobí to, že nahradí všetky pevne medzery za normálne medzery a potom si s tým TRIM už poradí.
Ach áno, chybka v rýchlosti. Som to len tak napísal a netestol - opravené.
Napíšte čo sa má diať ak bude výber väčší ako jedna bunka. Kam sa majú kopírovať? Ak bude čas poriešime. Ak by bol ten súbor bolo by to najpriekaznejšie.
Páni xlnc a marjankaj sú tunajší matadory, nechcú Vám zle. Slovník sa každému páčiť nemusí, ale znalosti sú neodškriepiteľné.
-Čo ak bude označených viac buniek ako 1 ? Má sa brať v úvahu ľavá horná, alebo vykonať makro pre celú oblasť naraz, alebo pre každú z označených buniek sa má vykonať zvlášť ?
-Vznikajú aj iné prípady, napr. označenie buniek v celom riadku/stĺpci pri zmazaní riadku/stĺpca, dôjde k označeniu celého riadka/stĺpca. V tomto prípade čo ? Dá za zistiť či je označený celý riadok/stĺpec, ale nieje to rozoznateľné od označenia užívateľom od označenia Excelom pri mazaní.
-Aké makro sa má vykonať? Každá skúmaná bunka má úplne samostatné ničomu nepodobné makro ? Alebo majú makro podobné/rovnaké a len sa mení nejaký parameter podľa bunky ? Vtedy netreba X makier, ale len sa na základe bunky vypočíta parameter.
Veľmi málo informácií.
Len náčrtovo:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Range("A1:A10"), Target) Is Nothing Then
'niečo to vykoná, ak je označená niektorá z buniek v A1:A10
End If
End Sub
alebo
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Select Case Target.Cells(1).Address
Case "$A$1": 'niečo to vykoná
Case "$A$2": 'vykoná niečo úplne totálne iné
Case "$A$3": 'a zase úplne iné
'... atď
End Select
End Sub
alebo X ďalších... Určite nebude nikto robiť všetky možné príklady. Zlepšite popis a priložte súbor k implementácii.
Lebo to nieje medzera (kód 32) ale "pevná medzera" (kód 160)
=TRIM(SUBSTITUTE(A2;CHAR(160);" "))
=PROČISTIT(DOSADIT(A2;ZNAK(160);" "))
Mepexg má pravdu. Chyba vo vzorci. Dalo by sa to aj maticovým vzorcom bez pomoci akýchkoľvek pomocných stĺpcov.
Priložte prílohu, mne to ide normálne, aj keď je zamknutý list.
Neprejde to ani keď prvý riadok vynecháte?
Upravené, zabudol som pridávať nové položky aj do poľa všetkých hodnôt, ktorá sa používa na načítanie do všetkých zoznamov, ale aj na získanie hodnoty pri kliku v menu. Pole som musel preto otočiť... to je nepodstatné.
Kontrola služobnej cesty prebieha na riadku 37 v procedúre Workbook_SheetChange modulu Tento_zošit.
Je to zamotané a zložité, a navyše je po mne cudziemu človeku niekedy ťažko skúmať, čo som ako a prečo tak či onak myslel. No skúste, či Vám tie kódy niečo povedia.
Vzorcom skúste takto.
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.
"Iba jedna vec" - zdá sa Vám to stále iba "iba" ?
Je to podstatne zložitejšie.
Š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
Pridajte tam
DoEvents
pred
Loop
ale pozor, prírastok dajte aspoň 10. Určite nie po 1, to budú skôr Vianoce kým to prejde po 1.
Uživatelské menu
\nMenu
On-line nástroje
Formulář Faktura
Formulář Faktura IV
Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.
RSS nejnovější články