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

• #11382 Delila_1 veterán Pulsar #11378

  Új Válasz 2011-09-19 11:14:31 #11382

  Ú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 Pulsar #11378 üzenetére

  Kijavítottam a hibát. A htm formátumban mentett, és Excelben megnyitott fájlon futtatsd a makrót.

  Sub Rend()
  Dim usor%, sor%
  
  Application.ScreenUpdating = False
  Range("A:A,E:F").Delete Shift:=xlToLeft 'Oszlopok törlése
  ActiveSheet.DrawingObjects.Delete 'Objektumok törlése
  
  usor% = Range("A1").End(xlDown).Row - 1 'Felső sor%ok törlése
  Rows("1:" & usor%).Delete Shift:=xlUp
  
  Columns("A:C").UnMerge 'Összevonások megszüntetése
  
  usor% = Range("A65536").End(xlUp).Row 'Dátum formátum
  Range("A1:A" & usor%).Select
  Selection.NumberFormat = "mmmm dd/"
  
  Selection.SpecialCells(xlCellTypeBlanks).Select 'Üres cellák kitöltése az A oszlopban képlettel
  Selection.FormulaR1C1 = "=R[-1]C"
  
  Columns("A:A").Select 'Érték beillesztése a képletek helyére
  With Selection
  .Copy
  .PasteSpecial Paste:=xlPasteValues
  End With
  
  Range("D1:D" & usor%).FormulaR1C1 = "=SEARCH(""Rendőr"",RC[-3])" 'Képlet a D oszlopba
  
  For sor% = usor% To 3 Step -1 'Üres sorok törlése
  If Cells(sor%, 2) = "" And IsError(Cells(sor%, 4)) Then Rows(sor%).Delete Shift:=xlUp
  If IsNumeric(Cells(sor%, 4)) Then Range(Cells(sor%, 1), Cells(sor%, 3)).HorizontalAlignment = xlCenterAcrossSelection
  Next
  
  Columns(4).Delete Shift:=xlToLeft 'D segédoszlop törlése
  Range("A1").Select
  Application.ScreenUpdating = True
  End Sub

• #11380 Delila_1 veterán Pulsar #11378

  Új Válasz 2011-09-19 09:12:22 #11380

  Ú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 Pulsar #11378 üzenetére

  Mented a fájlt htm formátumban. Behívod az Excelbe, és lefuttatod az alábbi makrót, amit egy másik füzetben tárolsz.

  Sub Rend()
  Dim usor As Long, sor As Long
  
  Application.ScreenUpdating = False
  
  'Oszlopok törlése
  Range("A:A,E:F").Delete Shift:=xlToLeft
  
  'Objektumok törlése
  ActiveSheet.DrawingObjects.Delete
  
  'Felső sorok törlése
  usor = Range("A1").End(xlDown).Row - 1
  Rows("1:" & usor).Delete Shift:=xlUp
  
  'Összevonások megszüntetése
  Columns("A:C").UnMerge
  
  'Dátum formátum
  usor = Range("A65536").End(xlUp).Row
  Range("A1:A" & usor).Select
  Selection.NumberFormat = "mmmm dd/"
  
  'Üres cellák kitöltése az A oszlopban képlettel
  Selection.SpecialCells(xlCellTypeBlanks).Select
  Selection.FormulaR1C1 = "=R[-1]C"
  
  'Érték beillesztése a képletek helyére
  Columns("A:A").Select
  With Selection
  .Copy
  .PasteSpecial Paste:=xlPasteValues
  End With
  
  'Üres sorok törlése
  For sor = usor To 3 Step -1
  If Cells(sor, 2) = "" Then Rows(sor).Delete Shift:=xlUp
  Next
  
  Range("A1").Select
  Application.ScreenUpdating = True
  
  End Sub

  Mivel a kapitányságok nem egyformán viszik be a dátumot, az A oszlopban lesz némi változatosság.

  [ Szerkesztve ]

• #11379 m.zmrzlina senior tag Pulsar #11378

  Új Válasz 2011-09-19 08:08:27 #11379

  Ú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 Pulsar #11378 üzenetére

  Lehet, hogy engem kiemelt ügyfélként kezel a rendőrség (eleget kerestek már rajtam ) de ha én lementem Excelbe a linken lévő oldalt (nem szövegként beillesztve hanem html-ként) akkor egy fia felesleges szóközt nem találok benne.

  Na jó, a táblázaton kívül van egy pár link meg kép egyhalomban de az egyszerűen törölhető. És a dátum sem ugyanúgy van megadva minden kapitányságnál de ennyi.

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