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

• #28662 Delila_1 Topikgazda szőröscica #28660

  Új Válasz 2015-09-16 19:16:34 #28662

  Ú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

  Topikgazda

  válasz szőröscica #28660 üzenetére

  Nem kell külön beolvastatni a fájlneveket, majd másolni, végül törölni a felesleges sorokat. Az alábbi makró mindegyik műveletet elvégzi.

  Két dolgot kell átírnod benne, az útvonalat, ahonnan a fájlokat behívod, és a kiterjesztést, ha 2007-es verziónál régebbi Excelt használsz.

  Sub Osszemasolas()
  Dim FN As String, utvonal As String, WS As Worksheet
  Dim hova As Long, tabla As Range, CV As Object
  
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set WS = ActiveWorkbook.ActiveSheet
  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 = Application.WorksheetFunction.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
  
  For Each CV In Selection
  If CV = "q" Or CV = "r" Then Rows(CV.Row).Delete
  Next
  FN = Dir()
  Loop
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  
  MsgBox "Kész", vbInformation
  End Sub

  Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

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