Doplneni hodnoty do bunky

[luko02420]

Dobrý večer, potřeboval bych poradit. Do bunky I3 nacitám hodnoty z jineho listu. Potrebuji aby se hodnota z I3 prenesla automaticky do A3 stejneho listu. Ale tak aby v A3 nebyl vzorec jenom hodnota z I3. Nevím jak toho docilit. Melo by to fungovat pro cely sloupec I. Vzdy hodnota v I a prenos do A.
Děkuji za pomoc.

[karlos64]

Dobrý den.
Není to stoprocentně automatické, ale je možné použít kopírování makrem spouštěné přes nějaké tlačítko. Bylo by to rychlé.

[luko02420]

Dobrý den, tak jsem našel kod od uzivatele "Cmuch".
Funguje skvěle, takže snad to tvurci nebude vadit když ho tu dám.
Mám tam akorát vypnuté řazení.
Snad se bude někomu hodit.

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)

Dim Oblast As Range
Dim puvodnivyber As Variant

'definice sledované oblasti
Set Oblast = Range("A5:A1000")
   'test výběru
  If Union(Oblast, Target).Address = Oblast.Address Then
   
    Application.ScreenUpdating = False 'zakazani updatovani stranky
    puvodnivyber = Target.Address      'zaznamenani posledni vybrane bunky
    ActiveWindow.FreezePanes = False   'vypnuti ukotveni pricky

    Range("A5:A1000").Copy
    Sheets("Souhrn").Range("A3:A1000").PasteSpecial
    Application.CutCopyMode = False
    
    'With Sheets("Souhrn")
        '.Range("A3:A1000").RemoveDuplicates Columns:=1, Header:=xlNo
        '.Sort.SortFields.Clear
        '.Sort.SortFields.Add Key:= _
                    'Range("A3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
         ' With .Sort
             '.SetRange Range("A3:A1000")
             '.Header = xlNo
             '.MatchCase = False
             '.Orientation = xlTopToBottom
             '.SortMethod = xlPinYin
             '.Apply
          'End With
    'End With
    
    Rows("5:5").Select               'vybrani radku od ktereho bude fungovat ukotveni pricky
    ActiveWindow.FreezePanes = True    'zapnuti ukotveni pricky
    Range(puvodnivyber).Select         'navrat na posledni vybranou bunku
    Application.ScreenUpdating = True  'zapnuti updatovani stranky
  End If
End Sub

[elninoslov]

Tento kód má ale nevýhodu v tom, že označuje oblasti a kopíruje ich, čo je pomalé. Ďalej nefunguje, ak zmena oblasti je viacstĺpcová (typicky mazanie). Tu je jednoduchší kód, ale pre oba platí, že treba dať pozor, ako vzniká hodnota v sledovanej zdrojovej oblasti. Či napísaním, alebo výpočtom. Treba sledovať zmenu v takej oblasti, ktorá má priamy vplyv od užívateľa na kopírované hodnoty. Inak by bolo potrebné kopírovať celú vyplnenú časť pri každom Calculate. Lebo vzorec nevyvolá Worksheet_Change. Iba užívateľ.

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Oblast As Range, Area As Range
    
    Set Oblast = Intersect(Range("G:G"), Target)    'definice změnené oblasti. Tu je lepšie kontrolovať iba rozumnú oblasť, napr. G1:G1000.
    If Not Oblast Is Nothing Then                   'test výběru
        Application.ScreenUpdating = False          'zakazani updatovani stranky
        For Each Area In Oblast.Areas               'projít všechny změnené podoblasti
            With Area
                wsCiel.Cells(.Row, 1).Resize(.Cells.Count).Value = .Value   'Přenesení hodnoty
            End With
        Next Area
        Application.ScreenUpdating = True           'zapnuti updatovani stranky
    End If
End Sub

Príklad:

[luko02420]

Dobrý den, zkusím toto bylo jedine co jsem nasel. Zapis do sledované oblasti se provadí rucne zapisem.