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

• #10537 m.zmrzlina senior tag gigi183 #10534

  Új Válasz 2011-06-17 12:43:18 #10537

  Ú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

  

  m.zmrzlina

  senior tag

  válasz gigi183 #10534 üzenetére

  Na próbálkoztam még, és működik, már csak annyit kellene megoldanom, hogy ha az aktuális lapot átmásolom mondjuk egy Today feliratú munkalapra, akkor az Nts oszlopban lévő számok eggyel csökkenjenek, vagy automatikusan, vagy gombbal.

  Erre a problémára új modulba (Inset>Module) tedd be a következőt:

  Sub masol()
  Application.ScreenUpdating = False 'képernyőftissítést tilt
  
  ActiveSheet.Copy after:=Sheets(ActiveWorkbook.Sheets.Count) 'lemásolja az aktív munkalapot és az utolsó munkalap után helyezi el
  ActiveSheet.Name = ActiveSheet.Index + 1 'ad neki nevet
  
  Range("E1048576").End(xlup).Select 'beáll az E oszlop utolsó cellájába
  Do Until ActiveCell.Value = "nts" 'ciklus amíg fel nem ér a fejlécig
  If ActiveCell.Value <> "" Then ActiveCell.Value = ActiveCell.Value - 1 'kivonja az egyet
  If ActiveCell.Value = 0 Then 'ha nts=0
  Range(ActiveCell.Offset(0, -3), ActiveCell.Offset(0, 4)).Value = "" 'a kívánt cellák tartalmának törlése
  End If
  ActiveCell.Offset(-1, 0).Select 'egy cellát fel
  Loop
  
  Application.ScreenUpdating = True 'képernyőftissítést engedélyez
  End Sub

  Nekem így néz ki a munkalapom amit kezel:

  

  Kiindulásnak jó aztán majd pontosítasz.

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