Note: The other languages of the website are Google-translated. Back to English

Jak počítat celkový počet kliknutí v určité buňce v aplikaci Excel?

Tento článek hovoří o počítání celkových kliknutí v určené buňce v aplikaci Excel.

Počítat celkový počet kliknutí v zadané buňce pomocí kódu VBA


Počítat celkový počet kliknutí v zadané buňce pomocí kódu VBA

Chcete-li spočítat celkový počet kliknutí v určité buňce v aplikaci Excel, postupujte takto.

1. V listu obsahuje buňku, kterou potřebujete spočítat její celkový počet kliknutí, klepněte pravým tlačítkem myši na kartu listu a poté klepněte na Zobrazit kód z kontextové nabídky.

2. V Microsoft Visual Basic pro aplikace zkopírujte a vložte pod kód VBA do okna Kód.

Kód VBA: Počet celkových kliknutí v zadané buňce v aplikaci Excel

Public xRgS, xRgD As Range
Public xNum As Long
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    Set xRgS = Range("E2")
    If xRgS Is Nothing Then Exit Sub
    Set xRgD = Range("H2")
    If xRgD Is Nothing Then Exit Sub
    If Intersect(xRgS, Target) Is Nothing Then Exit Sub
    xNum = xNum + 1
    xRgD.Value = xNum
End Sub

Poznámka: V kódu je E2 buňka, kterou potřebujete k výpočtu celkových kliknutí, a H2 je výstupní buňka počítání. Změňte je prosím podle potřeby.

3. zmáčkni Další + Q klávesy pro zavření Microsoft Visual Basic pro aplikace okno.

Od této chvíle se při kliknutí na buňku E2 v tomto zadaném listu automaticky klikne na celkový počet kliknutí v buňce H2, jak je ukázáno níže. Například pokud kliknete na buňku E2 5krát, číslo 5 se zobrazí v buňce H2.


Nejlepší kancelářské nástroje produktivity

Kutools pro Excel řeší většinu vašich problémů a zvyšuje vaši produktivitu o 80%

  • Opakované použití: Rychle vložte složité vzorce, grafy a cokoli, co jste dříve používali; Šifrovat buňky s heslem; Vytvořte seznam adresátů a posílat e-maily ...
  • Super Formula Bar (snadno upravit více řádků textu a vzorce); Rozložení pro čtení (snadno číst a upravovat velké množství buněk); Vložit do filtrovaného rozsahu...
  • Sloučit buňky / řádky / sloupce bez ztráty dat; Rozdělit obsah buněk; Zkombinujte duplicitní řádky / sloupce... Zabraňte duplicitním buňkám; Porovnat rozsahy...
  • Vyberte možnost Duplikovat nebo Jedinečný Řádky; Vyberte prázdné řádky (všechny buňky jsou prázdné); Super hledání a fuzzy hledání v mnoha sešitech; Náhodný výběr ...
  • Přesná kopie Více buněk beze změny odkazu na vzorec; Automaticky vytvářet reference do více listů; Vložte odrážky, Zaškrtávací políčka a další ...
  • Extrahujte text, Přidat text, Odebrat podle pozice, Odebrat mezeru; Vytváření a tisk mezisoučtů stránkování; Převod mezi obsahem buněk a komentáři...
  • Super filtr (uložit a použít schémata filtrů na jiné listy); Rozšířené řazení podle měsíce / týdne / dne, frekvence a dalších; Speciální filtr tučnou kurzívou ...
  • Kombinujte sešity a pracovní listy; Sloučit tabulky na základě klíčových sloupců; Rozdělte data do více listů; Dávkový převod xls, xlsx a PDF...
  • Více než 300 výkonných funkcí. Podporuje Office / Excel 2007-2021 a 365. Podporuje všechny jazyky. Snadné nasazení ve vašem podniku nebo organizaci. Plné funkce 30denní bezplatná zkušební verze. 60denní záruka vrácení peněz.
karta kte 201905

Office Tab přináší do Office rozhraní s kartami a usnadňuje vám práci

  • Povolte úpravy a čtení na kartách ve Wordu, Excelu, PowerPointu, Publisher, Access, Visio a Project.
  • Otevřete a vytvořte více dokumentů na nových kartách ve stejném okně, nikoli v nových oknech.
  • Zvyšuje vaši produktivitu o 50%a snižuje stovky kliknutí myší každý den!
officetab dno
Komentáře (29)
Zatím žádné hodnocení. Buďte první, kdo ohodnotí!
Tento komentář byl moderátorem webu minimalizován
Jak můžete "resetovat" počítadlo?
Tento komentář byl moderátorem webu minimalizován
milý dennisi,
Přidejte níže uvedený kód VBA na konec původního kódu. Pokaždé, když spustíte tento kód, počítání se resetuje na 0. Děkujeme za váš komentář.

Sub ClearCount()
xRgD.Value = ""
xNum = 0
End Sub
Tento komentář byl moderátorem webu minimalizován
Krystal,

Můžete k tomu poskytnout úplný kód VBA? také jak bych to použil na jeden řádek - každý potřebuje svůj vlastní čítač?
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Úplný kód VBA je následující. Pokud chcete počítadlo vynulovat, spusťte prosím druhý kód VBA. Za použití kódu na jeden řádek vám bohužel zatím nemohu pomoci.

„První VBA
Veřejné xRgS, xRgD jako rozsah
Veřejné xNum As Long
Private Sub Worksheet_SelectionChange (ByVal Target As Range)
On Error Resume Next
Pokud Target.Cells.Count > 1, pak Exit Sub
Nastavit xRgS = Range("E2")
Pokud xRgS není nic, pak Exit Sub
Nastavit xRgD = Range("H2")
Pokud xRgD není nic, pak Exit Sub
Pokud Intersect(xRgS, Target) není nic, pak Exit Sub
xNum = xNum + 1
xRgD.Value = xNum
End Sub
„Druhý VBA
Sub ClearCount()
xRgD.Value = ""
xNum = 0
End Sub
Tento komentář byl moderátorem webu minimalizován
Děkuji za kód, velmi užitečný.
Nejsem programátor a rád bych věděl, jak tento proces rozšířit na každý řádek. To znamená, že nejen E2>H2, ale také E3>H3, E4>H4 a tak dále.
Existuje na to kód?


Děkuji předem!
Tento komentář byl moderátorem webu minimalizován
Ahoj Guido,

Níže uvedený kód VBA vám může pomoci vyřešit problém. Zkuste to prosím. Děkuji za Váš komentář.
Private Sub Worksheet_SelectionChange (ByVal Target As Range)
Dim xRgArray jako varianta
Dim xNum
Dim xStrR, xStrS, xStrD jako řetězec
Dim xRgS, xRgD jako rozsah

Dim xFNum As Long
xRgArray = Array("E2,H2", "E3,H3", "E4,H4", "E5,H5", "E6,H6")
On Error Resume Next
Pokud Target.Cells.count > 1, Exit Sub
Pro xFNum = LBound(xRgArray) To UBound(xRgArray)
xStrR = xRgArray(xFNum)
xStrS = ""
xStrS = Left(xStrR, 2)
xStrD = ""
xStrD = Right(xStrR, 2)
Nastavit xRgS = nic
Nastavit xRgS = rozsah (xStrS)
If TypeName(xRgS) <> "Nothing" Then
Nastavit xRgD = nic
Nastavit xRgD = Range(xStrD)
If TypeName(xRgD) <> "Nothing" Then
If TypeName(Intersect(xRgS, Target)) <> "Nothing" Then
xRgD.Value = xRgD.Value + 1
End If
End If
End If
další
End Sub
Tento komentář byl moderátorem webu minimalizován
Díky za to. Zkusil jsem to a fungovalo to, ale fungovalo to pouze do určitého počtu buněk, jak můžeme tento kód rozšířit až na konec buněk? například zapíšu tento kód níže a funguje to pouze do "G9, G9". dík


Private Sub Worksheet_SelectionChange (ByVal Target As Range)
Dim xRgArray jako varianta
Dim xNum
Dim xStrR, xStrS, xStrD jako řetězec
Dim xRgS, xRgD jako rozsah

Dim xFNum As Long
xRgArray = Array("C4,C4", "D4,D4", "E4,E4", "F4,F4", "G4,G4", "C6,C6", "D6,D6", "E6,E6" ", "F6,F6", "G6,G6", "C7,C7", "D7,D7", "E7,E7", "F7,F7", "G7,G7", "C8,C8", "D8,D8", "E8,E8", "F8,F8", "G8,G8", "C9,C9", "D9,D9", "E9,E9", "F9,F9", "G9" ,G9", "C10,C10", "D10,D10", "E10,E10", "F10,F10", "G10,G10", "C11,C11", "D11,D11", "E11,E11" ", "F11,F11", "G11,G11", "C14,C14", "D14,D14", "E14,E14", "F14,F14", "G14,G14", "C15,C15", "D15,D15", "E15,E15", "F15,F15", "G15,G15", "C16,C16", "D16,D16", "E16,E16", "F16,F16", "G16" ,G16", "C17,C17", "D17,D17", "E17,E17", "F17,F17", "G17,G17", "C18,C18", "D18,D18", "E18,E18" ", "F18,F18", "G18,G18", "C20,C20", "D20,D20", "E20,E20", "F20,F20", "G20,G20")
On Error Resume Next
Pokud Target.Cells.count > 1, Exit Sub
Pro xFNum = LBound(xRgArray) To UBound(xRgArray)
xStrR = xRgArray(xFNum)
xStrS = ""
xStrS = Left(xStrR, 2)
xStrD = ""
xStrD = Right(xStrR, 2)
Nastavit xRgS = nic
Nastavit xRgS = rozsah (xStrS)
If TypeName(xRgS) <> "Nothing" Then
Nastavit xRgD = nic
Nastavit xRgD = Range(xStrD)
If TypeName(xRgD) <> "Nothing" Then
If TypeName(Intersect(xRgS, Target)) <> "Nothing" Then
xRgD.Value = xRgD.Value + 1
End If
End If
End If
další
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj Ruth,
Kód je obtížné optimalizovat, aby vyhovoval vašim potřebám. Omlouvám se za to.
Tento komentář byl moderátorem webu minimalizován
kód nečte dvojciferné číslo buňky, např. C10, proč to prosím je
Tento komentář byl moderátorem webu minimalizován
Ahoj, Crystal. Zkoušel jsem tento vzorec, ale hlásí se pouze přes řádek 9. Nebudu počítat řádek 10 a dále. Například jsem upravil výše uvedený vzorec pro počítání jednotlivých kliknutí v A4, pro hlášení do E5; A5 hlásit se na E5; A6 pro hlášení do E6 atd. Celkový rozsah je A4 až A17, celkové hlášení je E4 až E17. můžete pomoci? Zde je upravený kód, který jsem použil.



Private Sub Worksheet_SelectionChange (ByVal Target As Range)
Dim xRgArray jako varianta
Dim xNum
Dim xStrR, xStrS, xStrD jako řetězec
Dim xRgS, xRgD jako rozsah

Dim xFNum As Long
xRgArray = Array("A4,E4", "A5,E5", "A6,E6", "A7,E7", "A8,E8", "A9,E9", "A10,E10", "A11,E11" ", "A12,E12", "A13,E13", "A14,E14", "A15,E15", "A16,E16", "A17,E17")
On Error Resume Next
Pokud Target.Cells.Count > 1, pak Exit Sub
Pro xFNum = LBound(xRgArray) To UBound(xRgArray)
xStrR = xRgArray(xFNum)
xStrS = ""
xStrS = Left(xStrR, 2)
xStrD = ""
xStrD = Right(xStrR, 2)
Nastavit xRgS = nic
Nastavit xRgS = rozsah (xStrS)
If TypeName(xRgS) <> "Nothing" Then
Nastavit xRgD = nic
Nastavit xRgD = Range(xStrD)
If TypeName(xRgD) <> "Nothing" Then
If TypeName(Intersect(xRgS, Target)) <> "Nothing" Then
xRgD.Value = xRgD.Value + 1
End If
End If
End If
další
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj JT,
Děkujeme vám za vaši reakci. V původním kódu je něco špatně. Můžete vyzkoušet následující nový kód.
Číslo 4 v této lži: Set xRight = Target.Offset(0, 4) znamená, že 4 sloupce k posunutí vpravo od počáteční reference (počáteční reference je A4:A17). Po odsazení 4 sloupců doprava se výsledky zobrazí v E4:E17.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Updated by Extendoffice 20221010
    Dim xRight As Range

    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub
    If Intersect(Target, Range("A4:A17")) Is Nothing Then Exit Sub
    Set xRight = Target.Offset(0, 4)
    If TypeName(xRight.Value) = "Double" Then
        xRight.Value = xRight.Value + 1
    ElseIf TypeName(xRight.Value) = "Empty" Then
        xRight.Value = 1
    End If

End Sub
Tento komentář byl moderátorem webu minimalizován
Dobrý den, existuje způsob, jak zálohovat počítání pro libovolné číslo, které chci? Například: Udělal jsem 5 kliknutí, ale chtěl jsem jen 3. Takže změním číslo v buňce na 3, a když kliknu znovu, bude to pokračovat od 3.
Děkuji za kód!
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Je nám líto, s tím vám nemohu pomoci, vítáme vás, když můžete na našem fóru zveřejnit jakýkoli dotaz ohledně Excelu: https://www.extendoffice.com/forum.html. Získáte další podporu Excelu od našich profesionálních nebo jiných fanoušků Excelu.
Tento komentář byl moderátorem webu minimalizován
Haló
Hay alguna manera de programar el conteo de clicks de acuerdo la fecha, es decir programar varias celdas para que cuenten con la fecha del día?
Tento komentář byl moderátorem webu minimalizován
Můžete poskytnout kód, který umožňuje počítání kliknutí od buněk A2, B2 až po buňky A14, B14? Díky předem.
Tento komentář byl moderátorem webu minimalizován
Ahoj Barbara,
Myslíte počítání celkových kliknutí v rozsahu A2:B14? Nebo kliknutí na každou buňku v rozsahu A2:B14?
Tento komentář byl moderátorem webu minimalizován
Nastala nákaza? Jak resetovat skóre?
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
Pokud chcete počítadlo vynulovat, přidejte níže uvedený kód VBA na konec původního kódu, který byl poskytnut výše, a poté jej spusťte.

Sub ClearCount()
xRgD.Value = ""
xNum = 0
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj, snažím se najít způsob, jak spočítat počet kliknutí na 20 různých buněk (každá by se měla počítat samostatně). Narazil jsem na váš návrh kódu VBA, pokusil jsem se jej upravit podle mých konkrétních potřeb, ale nefunguje to. můžete mi prosím poradit jak se má ten kód napsat? buňky, které bych chtěl spočítat, a buňky, ve kterých by se měly hodnoty objevit, jsou: F12>AU12, F13>AU13, G12>AV12, G13>AV13, H10>AW10, H11>AW11, H12>AW12, H13>AW13 , H14>AW14, H15>AW15, I10>AX10, I11>AX11, I12>AX12, I13>AX13, I14>AX14, I15>AX15, J12>AY12, J13>AY13, K12>AZ12, K13>AZ13).
Toto je kód VBA, který jsem zkoušel bez úspěchu:

Private Sub Worksheet_SelectionChange (ByVal Target As Range)
Dim xRgArray jako varianta
Dim xNum
Dim xStrR, xStrS, xStrD jako řetězec
Dim xRgS, xRgD jako rozsah

Dim xFNum As Long
xRgArray = Array("F12,AU12", "F13,AU13", "G12,AV12", "G13,AV13", "H10,AW10", "H11,AW11", "H12,AW12", "H13,AW13" ", "H14,AW14", "H15,AW15", "I10,AX10", "I11,AX11", "I12,AX12", "I13,AX13", "I14,AX14", "I15,AX15", "J12,AY12", "J13,AY13", "K12,AZ12", "K13,AZ13")
On Error Resume Next
Pokud Target.Cells.Count > 1, pak Exit Sub
Pro xFNum = LBound(xRgArray) To UBound(xRgArray)
xStrR = xRgArray(xFNum)
xStrS = ""
xStrS = Left(xStrR, 2)
xStrD = ""
xStrD = Right(xStrR, 2)
Nastavit xRgS = nic
Nastavit xRgS = rozsah (xStrS)
If TypeName(xRgS) <> "Nothing" Then
Nastavit xRgD = nic
Nastavit xRgD = Range(xStrD)
If TypeName(xRgD) <> "Nothing" Then
If TypeName(Intersect(xRgS, Target)) <> "Nothing" Then
xRgD.Value = xRgD.Value + 1
End If
End If
End If
další
End Sub

Předem děkuji za Vaši pomoc.
Tento komentář byl moderátorem webu minimalizován
Ahoj, níže uvedený kód může pomoci. Zkuste to prosím. Děkuji. Private Sub Worksheet_SelectionChange (ByVal Target As Range)
Dim xRgS, xRgD jako rozsah
Dim xStrRg As String
Dim xFNum jako celé číslo
Dim xArr1, xArr2
Pokud Target.Cells.Count > 1, pak Exit Sub
xStrRg = "F12-AU12; F13-AU13; G12-AV12; G13-AV13; H10-AW10; H11-AW11; H12-AW12; H13-AW13; H14-AW14; H15-AW15; I10-AX10; I11-AX11; I12-AX12; I13-AX13; I14-AX14; I15-AX15; J12-AY12; J13-AY13; K12-AZ12; K13-AZ13"
On Error Resume Next
xArr1 = Split(xStrRg, ";")
Pro xFNum = 0 až UBound(xArr1)
xArr2 = Split(xArr1(xFNum), "-")
Nastavit xRgS = Range(xArr2(0))
Nastavit xRgD = Range(xArr2(1))
Pokud ne (Intersect(xRgS, Target) Is Nothing) Pak
xRgD.Value = xRgD.Value + 1
End If
další
End Sub
Tento komentář byl moderátorem webu minimalizován
Výše opravený kód je skvělý pro list, se kterým pracuji, děkuji. Ale mám otázku ohledně přidání makra času, aby se každý den (kromě víkendů) součet přesunul na další řádek v listu, například:
Řada 3 – 7. 1. 2021 "B1-B3; C1-C3; D1-D3" Řada 4 - 7. 2. 2021 "B1-B4; C1-C4; D1-D4" řada 5 - 7. 3. 2021 "B1-B5; C1-C5; D1-D5"
Tento komentář byl moderátorem webu minimalizován
Crystal, výše uvedený kód je skvělý pro list, se kterým pracuji, děkuji. Ale mám otázku ohledně přidání makra času, aby se každý den (kromě víkendů) součet přesunul na další řádek v listu, například:

Řádek 3 – 7. 1. 2021 „B1-B3; C1-C3; D1-D3“
Řádek 4 – 7. 2. 2021 „B1-B4; C1-C4; D1-D4“
Řádek 5 – 7. 3. 2021 „B1-B5; C1-C5; D1-D5“

Pokud je to možné? díky, Kene
Tento komentář byl moderátorem webu minimalizován
Ahoj, děkuji za tyto kódy VBA téměř pracovat pro mé potřeby. Obávám se, že skutečnost, že potřebuji přejít přes dvojciferné číslo, znamená, že to nebude fungovat. Potřebuji mít C8 až C110 a odpovídající součet je L8 až L110. Můžete pomoci? Předem děkuji.
Tento komentář byl moderátorem webu minimalizován
Ahoj Andy, následující kód VBA vám může udělat laskavost. Zkuste to prosím. Private Sub Worksheet_SelectionChange (ByVal Target As Range)
Dim xRgS, xRgD jako rozsah
Dim xStrRg As String
Dim xCStr, xVStr jako řetězec
Dim xItem As Integer
xCStr = "C8: C110" 'Rozsah buněk, u kterých chcete zaznamenávat kliknutí na každou buňku
xVStr = "L8:L110" 'Rozsah buněk, do kterých se mají záznamy umístit
Nastavit xRgS = rozsah (xCStr)
Nastavit xRgD = Range(xVStr)
Pokud ne (Intersect(xRgS, Target) Is Nothing) Pak
xItem = Target.Row - xRgS.Item(1).Row + 1
xRgD.Item(xItem).Value = xRgD.Item(xItem).Value + 1
End If
End Sub
Tento komentář byl moderátorem webu minimalizován
Existuje způsob, jak zpětně sledovat počet čísel? Například: udělal jsem 5 kliknutí, ale chtěl jsem jen 3. Takže změním číslo v buňce na 3, a když kliknu znovu, pokračuje to od 3. NEBO mám možnost stisknout další buňku a snížit počet o 1, pokud je to jednodušší.
Tento komentář byl moderátorem webu minimalizován
Dobrý den,
j'aimerai comment is pourrais le le nombre de clics sur les cellules D10 à M10 et le retranscrire à la ligne R10 et le faire pour toutes les lignes suivante donc compter les clics sur les cellules D11 à M11 et le ligne R11à etc ?

srdečně
Tento komentář byl moderátorem webu minimalizován
Ahoj DUFOUR,
Chcete-li spočítat počet kliknutí od D10 do M10 a vydat celkový počet kliknutí v R10, můžete k tomu použít následující kód VBA.
Poznámka: V kódu je rozsah "D10:M30“ znamená, že kód funguje pouze od řádku 10 do řádku 30, proto prosím zadejte řádky, které chcete počítat.
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'Updated by Extendoffice 20220609
    Dim xNum As Long
    Dim xRgCount, xRg As Range
    
    On Error Resume Next
    If Target.Cells.Count > 1 Then Exit Sub

    Set xRg = Range("D10:M30")
    If Intersect(xRg, Target) Is Nothing Then Exit Sub
    Set xRgCount = Range("R" & Target.Row)
    
    If IsNumeric(xRgCount.Value) Then
        xNum = xRgCount.Value + 1
    Else
        xNum = 1
    End If
    xRgCount.Value = xNum
End Sub
Tento komentář byl moderátorem webu minimalizován
Ahoj. Muchas gracias por los códigos.
Me gustaría saber como contar las veces que se hace clic sobre un enlace en una celda.
Děkuju mnohokrát.
Tento komentář byl moderátorem webu minimalizován
Ahoj jose maria,
Chcete-li počítat kliknutí na hypertextový odkaz, můžete vyzkoušet následující kód VBA.
Předpokládejme, že hypertextové odkazy jsou ve sloupci A a chcete, aby byl počet kliknutí vyplněn v odpovídající buňce sloupce B (jak je znázorněno na obrázku níže)
Vložte prosím následující kód do okna listu (kódu).

Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
'Updated by Extendoffice 20220805
    Dim Hyperlink As Range
    Set Hyperlink = Target.Range

    Hyperlink.Offset(0, 1) = Hyperlink.Offset(0, 1) + 1
End Sub

https://www.extendoffice.com/images/stories/comments/comment-picture-zxm/clicks_on_a_hyperlink.png
Zatím zde nejsou žádné komentáře
Zanechat své připomínky
Odesílání jako host
×
Ohodnoťte tento příspěvek:
0   Postavy
Doporučená umístění

Sociální sítě

Copyright © 2009 - www.extendoffice.com. | Všechna práva vyhrazena. Poháněno ExtendOffice. | |. | Sitemap
Microsoft a logo Office jsou ochranné známky nebo registrované ochranné známky společnosti Microsoft Corporation ve Spojených státech a / nebo jiných zemích.
Chráněno Sectigo SSL