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

• #29902 huliganboy addikt huliganboy #29900

  Új Válasz 2015-12-16 13:00:48 #29902

  Ú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

  

  huliganboy

  addikt

  válasz huliganboy #29900 üzenetére

  Végül ez lett a megoldás...

  Sub ttt()
  mappak = Array ' Nálad persze más és más
  ' lehet egy dir("e:",vbdirectory) a feltöltésben, ha egy mappán belül vannak.
  
  For Each mappa In mappak
  Set uj = Workbooks.Add
  fajl = Dir(mappa & "*.xls")
  celsor = 1
  Do While fajl <> ""
  Workbooks.Open Filename:=mappa & fajl, ReadOnly:=True
  sor = Range("a1").SpecialCells(xlLastCell).Row
  If celsor = 1 Then
  Range("a1", Range("a1").SpecialCells(xlLastCell)).Copy uj.Sheets(1).Cells(celsor, 1)
  celsor = celsor + sor
  Else
  Range("a2", Range("a1").SpecialCells(xlLastCell)).Copy uj.Sheets(1).Cells(celsor, 1)
  celsor = celsor + sor - 1
  End If
  ActiveWorkbook.Close False
  fajl = Dir()
  Loop
  uj.SaveAs mappa & "eredmeny.xls"
  'uj.Close False
  Next
  MsgBox "Kész"
  End Sub

  Viszont még ebbe bele kellene aplikálni, hogy a C oszlopban azonos sorokat törölje illetve a megadott oszlopokat is törölje!!

  [ Módosította: CoolMan ]

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