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

• #22173 Delila_1 veterán slashing #22169

  Új Válasz 2014-06-28 08:16:30 #22173

  Ú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 slashing #22169 üzenetére

  Az előbbi makró csak a megnyitott fájl adatainak a másolását oldotta meg. A mostaniban a fájlok megnyitása, és zárása is szerepel.

  A Pathname változóban írd át az útvonalat. Nem érdemes az összefűzendő fájlokat és azt, amelyikben összefűzöd, azonos mappában tartani.

  Sub ProcessFiles()
  Dim Filename, Pathname As String, WBN As String
  Dim wb As Workbook
  WBN = ActiveWorkbook.Name
  Pathname = "F:\Eadat\valami\"
  Filename = Dir(Pathname & "*.xls")
  Do While Filename <> ""
  Set wb = Workbooks.Open(Pathname & Filename)
  DoWork wb, WBN
  wb.Close SaveChanges:=True
  Filename = Dir()
  Loop
  End Sub

  Sub DoWork(wb As Workbook, WBN)
  Dim usor As Long, cell As Range, selectRange As Range
  With wb
  usor = .Sheets("Munka1").Range("A" & Rows.Count).End(xlUp).Row
  For Each cell In .Sheets(1).Range("A3:A" & usor)
  If (cell.Value <> "") Then
  If selectRange Is Nothing Then
  Set selectRange = cell
  Else
  Set selectRange = Union(cell, selectRange)
  End If
  End If
  Next cell
  
  usor = Workbooks(WBN).Sheets("mega").Range("A" & Rows.Count).End(xlUp).Row + 1
  selectRange.Copy
  Workbooks(WBN).Sheets("mega").Range("A" & usor).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  End With
  End Sub

• #22171 Delila_1 veterán slashing #22169

  Új Válasz 2014-06-28 07:32:49 #22171

  Ú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 slashing #22169 üzenetére

  [Sub it()
  Dim cell As Range, usor As Long
  Dim selectRange As Range
  
  usor = Sheets("Munka1").Range("A" & Rows.Count).End(xlUp).Row
  For Each cell In ActiveSheet.Range("A3:A" & usor)
  If (cell.Value <> "") Then
  If selectRange Is Nothing Then
  Set selectRange = cell
  Else
  Set selectRange = Union(cell, selectRange)
  End If
  End If
  Next cell
  
  usor = Sheets("mega").Range("A" & Rows.Count).End(xlUp).Row + 1
  selectRange.Copy
  Sheets("mega").Range("A" & usor).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  End Sub

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