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

• #20143 Mutt senior tag _NCT #20054

  Új Válasz 2014-01-18 19:14:14 #20143

  Ú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

  

  Mutt

  senior tag

  válasz _NCT #20054 üzenetére

  Hello,

  Megkésve, de vmi ilyen kóddal lehet automatizálni a feladatot.

  Sub Masol()
  Dim rngForras As Range
  Dim wsTarget As Worksheet
  
  'kijelöljük a forrás lapot
  Set rngForras = ActiveSheet.Cells
  'ha csak az aktuális tartomány kell akkor
  'Set rngForras = ActiveSheet.Cells.CurrentRegion
  
  'új lapot hozunk létre
  Set wsTarget = ThisWorkbook.Worksheets.Add(after:=Worksheets(Worksheets.Count))
  
  'másoljuk a forrást az új helyre
  rngForras.Copy
  
  With wsTarget
  Application.ScreenUpdating = False
  Dim vLastRow
  Dim i As Long
  Const DataCol As String = "C"
  Const StartRow = 2
  
  'beíllesztjük a forrást
  .Paste
  
  'kikeressük az utolsó sort
  vLastRow = .Cells(.Rows.Count, DataCol).End(xlUp).Row
  
  'beszúrás előtt számoljuk az F és G oszlop különbségét és M oszlopba tesszük, hasonló módon N-be is tudod tenni
  .Range("M" & StartRow).Resize(vLastRow - StartRow + 1).FormulaR1C1 = "=RC[-7]-RC[-8]"
  'a képleteket számmá alakítjuk
  .Range("M" & StartRow).Resize(vLastRow - StartRow + 1) = .Range("M" & StartRow).Resize(vLastRow - StartRow).Value
  
  'elindutjuk a keresést alulról felfelé menve
  For i = vLastRow To 2 Step -1
  'ha nem egyezik, akkor beszúrunk egy sort
  If .Cells(i, DataCol).Value <> .Cells(i - 1, DataCol).Value Then
  .Rows(i).Insert
  'a számlálót is frissítenünk kell mert eggyel több sorunk lett
  i = i - 1
  End If
  Next i
  Application.ScreenUpdating = True
  End With
  
  End Sub

  üdv.

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