Makro - načítanie hodnoty do jednej zo 4 buniek Vyřešeno

[ondaqo]

Zdravím všetkých,

riešim jednu otázku. Istý čas hľadám makro alebo možno funkciu nasledovného typu. Po kliknutí do bunky (B2 alebo C2 alebo D2 alebo E2) sa do danej bunky vloží číslo z inej bunky (A2), v ktorej je nejaká hodnota. Ak bude vložená hodnota napr v B2, ostatné tri bunky ostávajú vždy prázdne. Ak sa zmení bunka napr na C2 zase ostatné 3 bunky ostávajú prázdne. Takýmto spôsobom sa vyplní postupne asi 25 riadkov. Bunka z ktorej sa hodnoty načítavajú prislúcha vždy len danému riadku.
Dúfam, že som problém popísal zrozumiteľne a vopred vám všetkým ďakujem za nejakú radu, prípadne postreh, príp. pomoc ako by som sa mal uberať.

Veľmi by mi to uľahčilo prácu

ondaqo

[Reklama]

[Jjg]

Rozumím tomu dobře, že chcete v každém řádku přenést hodnotu ze sloupce A do určeného sloupce B, C, D nebo E?

A pro všechny listy v sešitu?

[ondaqo]

Presne tak, napr. hodnotu z A2 do B2 alebo C2 alebo D2 alebo E2...hodnotu z A3 do B3 - C3 - E3...A4 do B4 - C4 - E4 atď. V zošite je v podstate 7 listov rovnakých len majú iný názov- Pondelok, Utorok, Streda, Stvrtok, Piatok, Sobota, Nedela :) ďakujem

[cmuch]

Tak do modulu listu ve VBA vlož

Kód: Vybrat vše

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

  Dim radek As Long
  Dim ACAdr As Variant

  radek = Target.Row
  ACAdr = ActiveCell.Address

  If ACAdr = "$B$" & radek Or ACAdr = "$C$" & radek Or ACAdr = "$D$" & radek Or ACAdr = "$E$" & radek Then

    If Range("$B$" & radek).Value = Empty And Range("$C$" & radek).Value = Empty And Range("$D$" & radek).Value = Empty And Range("$E$" & radek).Value = Empty Then

      ActiveCell.Value = Range("A" & radek)
    End If
  End If
End Sub

// Edit
nevšim sem si že to má být pro všechny listy.
Takže toto vlož do modulu thisworkbook

Kód: Vybrat vše

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)

  Dim radek As Long
  Dim ACAdr As Variant

  radek = Target.Row
  ACAdr = ActiveCell.Address

  If ACAdr = "$B$" & radek Or ACAdr = "$C$" & radek Or ACAdr = "$D$" & radek Or ACAdr = "$E$" & radek Then

    If Range("$B$" & radek).Value = Empty And Range("$C$" & radek).Value = Empty And Range("$D$" & radek).Value = Empty And Range("$E$" & radek).Value = Empty Then

      ActiveCell.Value = Range("A" & radek)
    End If
  End If
End Sub

[ondaqo]

Super, ďakujem veľmi pekne. Nechcem byť nevďačný, ste veľmi šikovný. Je aj nejaká možnosť, že ak kliknem najprv do B a chcem zmeniť hodnotu na bunku C, aby sa hodnota v bunke B vymazala?? aj tak ďakujem za tento kód

[cmuch]

Opravu bych dal na doubleclik
Vlož zase do modulu thisworkbook

Kód: Vybrat vše

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
  Dim radek As Long
  Dim ACAdr As Variant

  radek = Target.Row
  ACAdr = ActiveCell.Address

  If ACAdr = "$B$" & radek Or ACAdr = "$C$" & radek Or ACAdr = "$D$" & radek Or ACAdr = "$E$" & radek Then

    If Not Range("$B$" & radek).Value = Empty Or Not Range("$C$" & radek).Value = Empty Or Not Range("$D$" & radek).Value = Empty Or Not Range("$E$" & radek).Value = Empty Then

      Range("B" & radek & ":E" & radek).Value = ""

      ActiveCell.Value = Range("A" & radek)
      Cancel = True
    End If
  End If
End Sub

//Edit
Nebo ty hodnoty tam vkládat rovnou na doubleclick, ale záleží jestli chceš mít možnost i opravy.

[Jjg]

Vidím, že jsem pomalý. Dávám tu i svůj výrobek - funguje na dvouklik včetně oprav.
Zkoušeno v Excel 2007.

[cmuch]

Řešení to také je,
jen bych doplnil na konec Cancel = True aby nezůstávala buňka otevřená pro úpravu.

[Jjg]

Je možno, i když právě to jsem nakonec vyhodil.

[ondaqo]

Super, obe riešenia mi vyhovujú, si naozaj makromajster :)