Doplnění některých údajů z listu na list Vyřešeno

[cmuch]

Ahoj,
Chtěl bych poprosit o radu.
Mám dokument ve kterém se do listu1 zadávají údaje, ale k některým údajů není potřeba vypisovat vše.
A na listu2 jsou pomocná data ve kterých je zadáno co se má automaticky vyplnit když se zadá na listu1 nějaké měření.
A já bych potřeboval aby se ty data automaticky přepsali z příslušného řádku listu2 na příslušný řádek listu1

Děkuji za Vaše nápady.

[Reklama]

[Azuzula]

Chce to trochu upřesnit. Není mi jasné, zda jsou pomocná data stále stejně rozložena jako v demu? Pokud ano, tak by to bylo příliš snadné, takže asi nebudou...
Tak mě napadá že by to šlo makrem přes cyklus a kontrolovat prázdné buňky a doplňovat data z druhého listu do prázdných buněk.

[cmuch]

Ano, ty názvy těch sloupcu budou stejne na obou listech.
Udělání přes cyklus mi je také jasné, ale nevím jak mám vyhledat určité měření z listu1 na listu2.

[Azuzula]

To měření bude mít nějaký název? Pak by se to dalo hledat podle toho názvu (nebo nějakého ID)

[cmuch]

Já potřebuji když se do slupce měrění na listu1 něco napíše aby se zkontroloval sloupec měření na listu2
a pokud je na nějakém řádku ten text z listu1 tak aby se doplnily udaje z listu2 (obsazené bunky na příslušném řádku) na list1.

[Azuzula]

To "něco" je něco konkrétního v určité buňce a nebo to je vždy různý zápis v různých buňkách?

[cmuch]

to něco bude vždy text co je na listu2 ve sloupci měření, ale může se stát že přibyde text i jiný.

[Azuzula]

Ok, budeme se tedy držet sloupce "Měření" jakožto vodítka a zároveň něčeho co můžeme hledat v druhém listu. Zatím bez toho dalšího textu, ale to potom už určitě zvládneš doupravit.

Kód: Vybrat vše

Sub najdi_a_dopln()

Dim data As Variant
Dim bunka1 As Variant
Dim bunka2 As Variant
Dim bunka3 As Variant
Dim bunka4 As Variant
Dim bunka5 As Variant
Dim bunka11 As Variant
Dim bunka12 As Variant
Dim bunka13 As Variant
Dim bunka14 As Variant
Dim bunka15 As Variant

'uloží zapsané hodnoty k porovnání z List1
data = Cells(ActiveCell.Row, 3) 'sloupek 3 "Měření"
'není tedy nutné mít označenou buňku přímo s tím hledaným textem
'stačí označit řádek v kterém budeme hledat

bunka1 = Cells(ActiveCell.Row, 1) 'sloupek 1
bunka2 = Cells(ActiveCell.Row, 2) 'sloupek 2
bunka3 = Cells(ActiveCell.Row, 4) 'sloupek 4
bunka4 = Cells(ActiveCell.Row, 5) 'sloupek 5
bunka5 = Cells(ActiveCell.Row, 6) 'sloupek 6

Sheets("List2").Select

For a = Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1 'prohledá každou buňku ve sloupci od spodu
    If Cells(a, 3) = data Then
        Cells(a, 3).Select
        'uloží nalezené hodnoty k porovnání z List2
        bunka11 = Cells(ActiveCell.Row, 1)
        bunka12 = Cells(ActiveCell.Row, 2)
        bunka13 = Cells(ActiveCell.Row, 4)
        bunka14 = Cells(ActiveCell.Row, 5)
        bunka15 = Cells(ActiveCell.Row, 6)
        Sheets("List1").Select
            'když bude buňka na List1 prázdná, tak se vloží hodnota z list2
            If bunka1 = "" Then Cells(ActiveCell.Row, 1).Value = bunka11
            If bunka2 = "" Then Cells(ActiveCell.Row, 2).Value = bunka12
            If bunka3 = "" Then Cells(ActiveCell.Row, 4).Value = bunka13
            If bunka4 = "" Then Cells(ActiveCell.Row, 5).Value = bunka14
            If bunka5 = "" Then Cells(ActiveCell.Row, 6).Value = bunka15
    End If
    Next a
End Sub



PS: nejsem profík a možná by to šlo i zjednodušit, ale nevím jak. Ale funguje to snad tak jak je třeba.

[cmuch]

Ahoj,
děkuji za makro, ale není to přesně ono.
Zplodil jsem to co by bylo lepší, ale nejde mi nějak udělat aby to kopírovalo z listu na list, asi mám někde chybu
Mám to umístěné na list1

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)

Dim SRow As Range, CRow As Range
Dim RCll As Integer
Dim NmMereni As String
Dim a As Integer
Dim Cll2 As Range
Dim RCll2 As Integer, CCll2 As Integer

'test vyberu bunky
  If Not Intersect(Target, Me.Range("A:F")) Is Nothing Then
     ' zdrojovy radek
     Set SRow = Me.Range("A1:F1").Offset(Target.Row - 1, 0)
     RCll = SRow.Row
     ' nazev
     NmMereni = SRow.Columns(3).Value

     For a = Sheets("List2").Cells(Rows.Count, 3).End(xlUp).Row To 1 Step -1 'prohledá každou buòku ve sloupci od spodu
        If Sheets("List2").Cells(a, 3) = NmMereni Then
            Set CRow = Sheets("List2").Range("A" & a & ":F" & a)
                ' zjistit, zda se ma neco prepsat
            For Each Cll2 In CRow.Cells
                If Not IsEmpty(Cll2) Then
                     CCll2 = Cll2.Column
                     RCll2 = Cll2.Row
                     'toto nevim jak napsat
                     Sheets("List1").Cells(CCll2 & RCll) = Cll2
                End If
            Next Cll2
            Set Cll2 = Nothing
        End If
    Next a
 End If
   
End Sub


Děkuji za popostrčení.

--- Doplnění předchozího příspěvku (30 Led 2012 20:05) ---

Tak jsem to vyřešil
toto:

Kód: Vybrat vše

 'toto nevim jak napsat
                     Sheets("List1").Cells(CCll2 & RCll) = Cll2


jsem nahradil timto:

Kód: Vybrat vše

'toto nevim jak napsat
                     Application.EnableEvents = False
                     Sheets("List1").Cells(RCll, CCll2) = Cll2
                     Application.EnableEvents = True

jak je vidět v zápisu jsem měl chybu jak hrom