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

• #18150 Mutt senior tag motinka #18145

  Új Válasz 2013-05-26 22:02:06 #18150

  Ú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 motinka #18145 üzenetére

  Hello,

  Itt vannak a kész változatok.

  Szóval ahogy írtam több megoldás is lehetséges.

  1. Írtam egy makrót, amely minden egyes adatbevitelkor megnézi hogy van-e mit mozgatni és ilyenkor az egészet átviszi és sorbarendezi. A beviteli lap Change eseménye hívja meg. A beviteli lap tartalma az adat2-n jelenik meg.

  Sub Adatmasolas()
  Const wsEredeti = "adat"
  Const wsCel = "adat2"
  Dim vLastRowEredeti As Long
  Dim vLastRowCel As Long
  
  'megnézzük az eredeti lapon az utolsó sor helyét
  vLastRowEredeti = ThisWorkbook.Sheets(wsEredeti).Range("B" & Rows.Count).End(xlUp).Row
  
  'megnézzük az cél lapon ahova másolunk az utolsó sor helyét
  vLastRowCel = ThisWorkbook.Sheets(wsCel).Range("B" & Rows.Count).End(xlUp).Row - 1
  
  'ha több sor van az eredeti lapon akkor lehet másolni a másikra
  If vLastRowEredeti > vLastRowCel Then
  
  'képernyőfrissítés kikapcsolása
  Application.ScreenUpdating = False
  
  With ThisWorkbook.Sheets(wsEredeti)
  'naptár kód másolása
  .Range("X2:X" & vLastRowEredeti).Copy Destination:=Sheets(wsCel).Range("A3")
  'dátum másolása
  .Range("B2:B" & vLastRowEredeti).Copy Destination:=Sheets(wsCel).Range("B3")
  'munkalapszám másolása
  .Range("C2:C" & vLastRowEredeti).Copy Destination:=Sheets(wsCel).Range("C3")
  'munka kezdete másolása
  .Range("T2:T" & vLastRowEredeti).Copy Destination:=Sheets(wsCel).Range("D3")
  'munka vége másolása
  .Range("U2:U" & vLastRowEredeti).Copy Destination:=Sheets(wsCel).Range("E3")
  'munkakód másolása
  .Range("I2:I" & vLastRowEredeti).Copy Destination:=Sheets(wsCel).Range("F3")
  'lezáró kód másolása
  .Range("W2:W" & vLastRowEredeti).Copy Destination:=Sheets(wsCel).Range("G3")
  End With
  
  'sorbarendezés dátum szerint
  Sheets(wsCel).Activate
  With ThisWorkbook.Sheets(wsCel)
  .Columns("A:G").Select
  .Columns.AutoFit
  .Sort.SortFields.Clear
  .Sort.SortFields.Add Key:=Range("B2:B" & vLastRowEredeti), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
  .Sort.SetRange Range("A2:G" & vLastRowEredeti)
  .Sort.Header = xlYes
  .Sort.SortMethod = xlPinYin
  .Sort.Apply
  End With
  
  Sheets(wsEredeti).Activate
  
  'képernyőfrissítés visszaállítása
  Application.ScreenUpdating = True
  
  'kijelölés megszüntetése
  Application.CutCopyMode = False
  End If
  End Sub

  2. A másik megoldás pedig beépített függvényeket tartalmaz, kell hozzá egy ségédtábla és a függvényeket legalább addig le kell másolnod amennyi lesz a várható adatsor (én csak az első 300 sorba másoltam őket).
  A megoldás a 3. lapon van.

  3. A Kimutatás is használható lehet, azonban a megadott mintában nem volt elegendő egyedi érték, így az ismétlődéseket nem tudja kezelni.

  üdv.

• #18147 motinka tag motinka #18145

  Új Válasz 2013-05-26 18:48:59 #18147

  Ú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

  

  motinka

  tag

  válasz motinka #18145 üzenetére

  közben dolgoztam és ezt sikerült:

  http://www.hunsurf.hu/teszt_20130524_x1.xltm

  a CTRL + M - re indul a makró és számol

  köszönet az 5letekért, de ha van még szívesen veszem

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