Új hozzászólás Aktív témák

• #10422 Delila_1 veterán m.zmrzlina #10421

  Új Válasz 2011-06-01 17:32:38 #10422

  Új hozzászólás

  Összes hozzászólása itt Válaszok az összes hozzászólására itt Válaszok erre a hozzászólásra

  Privát üzenet küldése

  

  Delila_1

  veterán

  válasz m.zmrzlina #10421 üzenetére

  Private Sub Worksheet_Change(ByVal Target As Range)
  'A B.xls füzetből indulunk. A munkalaphoz rendelt eseménykezelő
  'csak a saját munkalapján tud dolgozni, ezért innen indítunk
  'olyan makrókat, amik nincsenek munkalaphoz rendelve.
  
  Application.EnableEvents = False 'Eseménykezelés letiltása
  Dim utvonal, Érték, sor%
  
  sor% = Target.Row 'Adatbevitel sora
  utvonal = Cells(sor%, 1) 'Az A oszlopba bevitt érték
  
  If Target.Column = 1 Then 'Ha az A oszlopba vittél be adatot,
  Darabteli utvonal, sor% 'meghívom a Darabteli makrót, átadva a 2 változót
  End If
  
  If Target.Column = 2 Then 'Ha a B oszlopba írsz értéket,
  Érték = Cells(sor%, 2) 'az Érték változó vegye fel a bevitt értéket
  Beír Érték 'Beír makró meghívása, az Érték változó átadásával
  End If
  Application.EnableEvents = True 'Eseménykezelés engedélyezése
  End Sub

  Sub Darabteli(utvonal, sor%)
  'Ez a makró az átvett "utvonal" változót keresi az A.xls Munka1 lapján, a B oszlopban,
  'a COUNTIF (darabteli) függvénnyel. A B.xls A oszlopába történt beírás hívja meg a makrót.
  Dim ws As Object, usor%
  
  Set ws = Workbooks("A.xls").Sheets("Munka1") 'A ws változó tartalma innen kezdve az egyenlőség jobb oldala
  usor% = ws.Range("B1").End(xlDown).Row + 1 'Első üres sor a ws.B oszlopában
  
  If Application.WorksheetFunction.CountIf(ws.Range("B:B"), utvonal) = 0 Then
  'Ha a B.xls A oszlopába beírt "utvonal" nem található az A.xls B oszlopában,
  'vagyis a darabteli=0
  ws.Cells(usor%, 2) = utvonal 'az utvonal változót írja be az ws.B oszlop első üres sorába
  Else
  'ha van "utvonal" a ws.B oszlopában, keresse meg, és a hozzá tartó H oszlopban lévő értéket
  'írja be a kiinduló füzet (B.xls) B oszlopába.
  'Itt nem kell a B.xls-re hivatkozni, mert nem léptünk át Select-tel az A.xls-be, csak leskelődtünk.
  Cells(sor%, 2) = Application.WorksheetFunction.VLookup(utvonal, ws.Columns("B:H"), 7, 0)
  End If
  End Sub

  Sub Beír(Érték)
  'A B.xls B oszlopába történt beírás hívja meg ezt a makrót.
  'Akkor írsz értéket a B oszlopba, ha az fkeres nem talált A oszlopbeli útvonalat.
  Dim ws As Object, usor%
  
  Set ws = Workbooks("A.xls").Sheets("Munka1") 'Mint fent
  usor% = ws.Range("H1").End(xlDown).Row + 1 'Mint fent
  ws.Cells(usor%, 8) = Érték 'A ws.H oszlop első üres sorába beírja az értéket
  End Sub

  Az eseménykezelés letiltása azért kell a laphoz rendelt makróba, mert a munkalapon történt minden változásra beindul. Próbáld ki az Application.EnableEvents = False sor nélkül lépésenként futtatni, és meglátod, hányszor fut le feleslegesen. A lépésenként futtatáshoz tegyél a makró elejére egy stop-ot, majd írj a B.xls-be egy útvonalat, vagy km-t.
  Az end sub előtt vissza kell állítani True értékkel!

Új hozzászólás Aktív témák