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

• #22176 slashing senior tag

  Új Válasz 2014-06-29 03:50:12 #22176

  Ú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

  

  slashing

  senior tag

  Kiegészítettem két sorral hát ha kell másnak is az első ami kikapcsolja vagy legalábbis nem mutatja a megnyitás bezárást(Application.ScreenUpdating = False) így gyorsul a program kb. 25-50%-ot illetve ha sok adat kerül a vágólapra a kilépésnél mindig feldobott egy ablakot hogy megtartom-e vagy sem(Application.CutCopyMode = False).

  A ScreenUpdating-et vissza kell amúgy kapcsoltatni a makró végén vagy nem szükséges?

  Sub teszt_61201121()
  Dim Filename, Pathname As String, WBN As String
  Dim wb As Workbook
  Application.ScreenUpdating = False
  WBN = ActiveWorkbook.Name
  Pathname = "c:\teszt\6120-1121\"
  Filename = Dir(Pathname & "*.xls")
  Do While Filename <> ""
  Set wb = Workbooks.Open(Pathname & Filename)
  DoWork wb, WBN
  Application.CutCopyMode = False
  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("C3:C" & 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("6120-1121 PCB OLDAL").Range("A" & Rows.Count).End(xlUp).Row + 1
  selectRange.Copy
  Workbooks(WBN).Sheets("6120-1121 PCB OLDAL").Range("A" & usor).PasteSpecial Paste:=xlPasteAll, Transpose:=True
  End With
  End Sub

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