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

• Delila_1 veterán

  #28663

  #28660 szőröscica

  2015-09-16 19:32:46

  Új Válasz

  Ú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

  

  Delila_1

  veterán

  #28660 szőröscica

  Kicsit gyorsítva az előbbi (törli a sorokat, ahol bármelyik oszlopban szerepel a q vagy az r):

  Sub Osszemasolas()
  Dim FN As String, utvonal As String, WS As Worksheet
  Dim hova As Long, WF As WorksheetFunction, vege As Long, sor As Long
  Dim tabla As Range
  
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set WS = ActiveWorkbook.ActiveSheet
  Set WF = Application.WorksheetFunction
  utvonal = "F:\Eadat\Tmp\" 'fájlok útvonala, írd át
  FN = Dir(utvonal & "*.xlsx") '2007-es előtti verziónál xls-re írd át
  
  Do While FN <> ""
  hova = WF.CountA(Columns(1)) + 1
  Workbooks.Open utvonal & FN
  Sheets("Data").Select
  
  Range("A1").Select
  Set tabla = Cells.CurrentRegion
  tabla.Offset(1, 0).Resize(tabla.Rows.Count - 1, tabla.Columns.Count).Copy
  
  WS.Cells(hova, "A").PasteSpecial Paste:=xlPasteAll
  
  Windows(FN).Close False 'Zárja a megnyitott fájlt mentés nélkül
  
  vege = WF.CountA(Columns(1))
  For sor = hova To vege
  If WF.CountIf(Rows(sor), "q") > 0 Or WF.CountIf(Rows(sor), "r") > 0 Then
  Rows(sor).Delete shift:=xlUp
  End If
  Next
  
  FN = Dir()
  Loop
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  
  MsgBox "Kész", vbInformation
  End Sub

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