Excel: potřebuji makro pro porovnání dat Vyřešeno

[navstevnik]

Udalostni procedura respektujici posledni pozadavek- modul list2:

Kód: Vybrat vše

Private Sub Worksheet_Change(ByVal Target As Range)
' udalostni procedura snizi stav ks v prislusnem zaznamu na list1,
' zaznamy na list1 jsou jedinecne
' deklarace promennych
  Dim Cll As Range, SBlk As Range, OK As Boolean
  ' omezeni rozsahu promenne target na jednu bunku pri mazani bloku bunek
  Set Target = Target.Resize(1, 1)
  ' test, zda Target je ze sloupce D:D
  If Not Intersect(Target, Me.Range("d:d")) Is Nothing Then
    ' nastavi promennou OK na hodnotu False
    OK = False
    ' nastavit blok bunek na listu1
    With Worksheets("list1")
      Set SBlk = Intersect(.UsedRange, .Range("a:a"))
    End With
    ' prohledat sloupec A:A na listu1, hledat hodnotu z list2!Axx - nazev
    With SBlk
      Set Cll = .Find(Target.Offset(0, -3).Value, LookIn:=xlValues, LookAt:=xlWhole)
      If Not Cll Is Nothing Then
        ' nalezeno ve sloupci A:A, overit zda se shoduje upresneni
        If Cll.Offset(0, 1).Value = Target.Offset(0, -2).Value Then
          ' overit, zda seshoduje i nazev
          If Cll.Offset(0, 2).Value = Target.Offset(0, -1).Value Then
            ' snizit hodnotu kusu na listu1, kdyz bude vysledek >=0
            If Cll.Offset(0, 3).Value - Target.Value >= 0 Then
              Cll.Offset(0, 3).Value = Cll.Offset(0, 3).Value - Target.Value
            Else
              MsgBox "Zustatek je < 0, blabla..."
              ' odstranit vlozenou hodnotu kusu na listu2, potlacit prepocet a volani procedury
              Application.EnableEvents = False
              Target.Value = vbNullString
              Application.EnableEvents = True
            End If
            OK = True
          End If
        End If
      End If
    End With
    Set Cll = Nothing
    Set SBlk = Nothing
    If Not OK Then MsgBox "Nenalezeno...blabla"
  End If
End Sub

[Reklama]

[kluluk]

Mockrat dekuji, funguje vyborne.
Mam jeste jednu prosbicku tohle je perfektni a uz to funguje jak ma. Akorat mam problem o kterem jsem predtim nevedel.
Mam na prvnim listu tenhle kod, ktery mi hlida, kdyz uzivatel zmeni kusy na 0, tak smaze cely radek. Jenze kdyz to zmeni makro tak mi to nejak nereaguje. Mohl bych poprosit jeste o pomoc a malou upravu nasledujiciho kodu?
dekuji moc kluluk



Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = "4" Then
Call smazat_nuly
End If
End Sub


Sub smazat_nuly()
Dim Firstrow As Long
Dim Lastrow As Long
Dim Lrow As Long
Dim CalcMode As Long
Dim ViewMode As Long
With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
End With
With ActiveSheet
.Select
ViewMode = ActiveWindow.View
ActiveWindow.View = xlNormalView
.DisplayPageBreaks = False
Firstrow = .UsedRange.Cells(4).Row
Lastrow = .UsedRange.Rows(.UsedRange.Rows.Count).Row
For Lrow = Lastrow To Firstrow Step -1
With .Cells(Lrow, "D") ' Sloupec s hledanými podmínkami
If Not IsError(.Value) Then
Select Case .Value
Case Is = "0": .EntireRow.Delete 'podmínka v uvozovkách
End Select
End If
End With
Next Lrow
End With
ActiveWindow.View = ViewMode
With Application
.Calculation = CalcMode
End With
End Sub

[navstevnik]

Pokud je potreba odstranit zaznam na list1 v pripade, kdy uzivatel v zaznamu na tomto listu vynuluje pocet ks nebo je pocet ks vynulovan po zapisu poctu ks na listu2 prislusnou udalostni procedurou listu2, pak postaci nasledujici procedura vlozena do modulu list1:

Kód: Vybrat vše

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
' udalostni procedura odstrani zaznam, ve kterem byl pocet ks dodatecne vynulovan
' omezeni rozsahu promenne target na jednu bunku pri mazani bloku bunek
  Set Target = Target.Resize(1, 1)
  ' test, zda Target je ze sloupce D:D
  If Not Intersect(Target, Me.Range("d:d")) Is Nothing Then
    If Target.Value <= 0 Then
      Application.EnableEvents = False
      Target.EntireRow.Delete Shift:=xlShiftUp
      Application.EnableEvents = True
    End If
  End If
End Sub

[kluluk]

Dekuji, dekuji, dekuji :-)
Vsechno funguje jak ma.
Diky za pomoc kluluk

// Označuji za vyřešené. Příště prosím viewtopic.php?f=85&t=26719&p=160986#p160986
// mike007