EXCEL makro - vyhledani a kopie radku Vyřešeno

[jiri255]

Zdravím,
chtěl bych požádat o radu ohledně jednoho makra. Makro funguje tak, že když na listu2
zadám do buňky "B2" číselný kód, tak ho to po ENTRU porovná s kódy na listu1 a pokud
kód souhlasí,tak to odečte množství o "1" pokud to kód nenajde, tak to vyhodí hlášku,
že kód nebyl nalezen. To všechno funguje skvěle, ale já bych ještě potřeboval, že když
ten kód souhlasí a odečte to to množství, tak by to mělo ještě ten celý řádek s tím nalezeným
kódem překopírovat na list2 do řádku "A10" a pokud zadám další kód a ENTER, tak by to
mělo ten nalezený řádek překopírovat do další následné buňky "A11" a tak dále.
Doplnil, jsem tam to kopírování, ale myslím, že na to jdu špatně, protože to nefunguje
dobře a kopíruje to jen tu buňku s tím množstvím a kód ani název s toho řádku
to nezkopíruje
Mohl by mi s tím někdo poradit?
Předem moc děkuji za případnou pomoc a přikládám makro + vzorový excel.

kody.xls

(40 KiB) Staženo 50 x

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
  If Target.Address = "$B$2" Then
    If Not IsEmpty(Target) Then
      On Error Resume Next
      With Sheets("List1").Cells(Application.WorksheetFunction.Match(Target.Value, Sheets("List1").Columns(1), 0), 2)
        If Err.Number = 0 Then
        .Value = .Value - 1
        .Copy = .Copy.Range("A:C").Select      'toto jsem doplnil
        Sheets("List2").Select                   'toto jsem doplnil
        Range("A10").Select              'toto jsem doplnil
        ActiveSheet.Paste               'a toto jsem doplnil
        Target.ClearContents
        Range("B2").Select
      Else
        MsgBox "Neznámý kód!"
        Range("B2").Select
      End If
      End With 'Sheets("List1").Cells(Application.WorksheetFunction.Match(Target.Value, Sheets("List1").Columns(1), 0), 2)
      On Error GoTo 0
    End If
 End If


[Reklama]

[cmuch]

Trochu jsem to poupravil

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim SrcRange As Range
 Dim FindRow As Integer, NewRow As Integer

  If Target.Address = "$B$2" Then
    If Not IsEmpty(Target) Then
      Application.EnableEvents = False
      On Error Resume Next
      With Sheets("List1").Cells(Application.WorksheetFunction.Match(Target.Value, Sheets("List1").Columns(1), 0), 2)
        FindRow = .Row
        Set SrcRange = Sheets("List1").Range("A" & FindRow & ":C" & FindRow)
        If Err.Number = 0 Then
        .Value = .Value - 1
          With Sheets("List2")
            NewRow = .Cells(Rows.Count, "A").End(xlUp).Row + 1
            .Range("A" & NewRow & ":C" & NewRow).Value = SrcRange.Value
          End With 'Sheets("List2")
          Range("B2").ClearContents
        Else
          MsgBox "Neznámý kód!"
        End If
      End With 'Sheets("List1").Cells(Application.WorksheetFunction.Match(Target.Value, Sheets("List1").Columns(1), 0), 2)
      On Error GoTo 0
      Application.EnableEvents = True
    End If
  End If
  Range("B2").Select
End Sub

[jiri255]

odzkoušel jsem, ale nějak mi to nefunguje, když na listu2 zadám do B2 kód třeba 2222,
tak to jen přesune to číslo 2222 do buňky A1 a pak to vyhodí chybu, problém v makru
u tohoto řádku "Range("B2").Select"

Dodatečně přidáno po 10 hodinách 47 minutách 18 vteřinách:
tak ono to makro funguje, tak jak jsem potřeboval jen tomu vadí ten "list2",
když jsem to změnil:

Kód: Vybrat vše

With Sheets("List2")


na list3, tak se po vyplnění buňky B2 existujícím kódem, množství
na listu1 poníží o -1 a zároveň se řádek zkopíruje na list3 což je super,
ale kopírování začíná na řádku A2 což je asi ten důvod proč to na tom
listu2 nefunguje...
Nemůžu v tom makru přijít na to, jak mu říct, aby začínal vkládat ty
zkopírované řádky až od řádku A10 a ještě lze nějak ošetřit, když klesne
odečítáním množství na "0" ,aby vyhodil hlášku, že ten kód již nelze odečítat,
protože je množství na nule a nepokračoval v odečítání na -1, -2, atd.?

[cmuch]

Tady je úprava, normálně jde i na List2

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
 Dim SrcRange As Range
 Dim FindRow As Integer, NewRow As Integer

  If Target.Address = "$B$2" Then
    If Not IsEmpty(Target) Then
      Application.EnableEvents = False
      On Error Resume Next
      With Sheets("List1").Cells(Application.WorksheetFunction.Match(Target.Value, Sheets("List1").Columns(1), 0), 2)
        FindRow = .Row
        Set SrcRange = Sheets("List1").Range("A" & FindRow & ":C" & FindRow)
        If Err.Number = 0 Then
        If .Value <= 0 Then
            MsgBox "Zboží je na nule !", vbCritical
            GoTo konec
         End If
        .Value = .Value - 1
          With Sheets("List2")
            NewRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
            If NewRow < 10 Then NewRow = 10
            .Range("A" & NewRow & ":C" & NewRow).Value = SrcRange.Value
          End With 'Sheets("List2")
          Range("B2").ClearContents
        Else
          MsgBox "Neznámý kód!"
        End If
      End With 'Sheets("List1").Cells(Application.WorksheetFunction.Match(Target.Value, Sheets("List1").Columns(1), 0), 2)
konec:
      On Error GoTo 0
     
      Application.EnableEvents = True
    End If
  End If
  Range("B2").Select
End Sub



[jiri255]

děkuji cmuchovi za úpravu je to úplně super a funguje to naprosto perfektně
přesně tohle jsem potřeboval. Ještě jednou moc díky