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

• #28661 poffsoft veterán szőröscica #28660

  Új Válasz 2015-09-16 19:11:04 #28661

  Ú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

  

  poffsoft

  veterán

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

  szia,
  ha jól értettem:

  Sub pasteall()
  
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Dim PL, files As Variant
  Dim i, j As Long
  Dim k, l, m, n As Long
  Dim wbname As String
  Dim rng As Range
  Dim rw As Range
  Dim cell As Range
  
  
  ' select this workbook and clear all the input sheets
  
  wbname = ThisWorkbook.Name
  
  Workbooks(wbname).Activate
  Sheets("Data Sheet").Activate
  Range("D4:U1000000").ClearContents
  
  
  'copy data
  
  For i = 1 To Range("WorkbookCount").Value
  
  workbookpath = Range("Workbook_Name_Header").Offset(i, 0)
  PL = Range("Desk_Name_Header").Offset(i, 0)
  files = Range("File_Name").Offset(i, 0)
  
  
  
  
  Workbooks.Open (workbookpath)
  
  Sheets("Data").Activate
  Range("A65000").Select
  Selection.End(xlUp).Select
  
  l = Selection.Row
  Range("A2:W" & l).Select
  Selection.Copy
  
  
  Workbooks(wbname).Activate
  Sheets("Data Sheet").Activate
  Range("A1035000").Select
  Selection.End(xlUp).Select
  
  Selection.Offset(1, 0).Select
  
  Selection.PasteSpecial Paste:=xlPasteValues
  
  'Uj resz
  Set rng = Selection
  For Each rw In rng.Rows
  rw.Select
  Set cell = Selection.Find(What:="q", After:=Selection(1, 1), LookIn:=xlFormulas, _
  LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
  MatchCase:=False, SearchFormat:=False)
  
  If Not cell Is Nothing Then
  Selection.EntireRow.Delete
  Else
  Set cell = Selection.Find(What:="d", After:=Selection(1, 1), LookIn:=xlFormulas, _
  LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
  MatchCase:=False, SearchFormat:=False)
  If Not cell Is Nothing Then Selection.EntireRow.Delete
  End If
  Next
  ' Uj resz vege
  
  
  Application.CutCopyMode = False
  
  Workbooks(files).Activate
  ActiveWorkbook.Close
  
  
  Next i
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  
  
  End Sub

  Nem teljesen dolgoztam fel, mit is csinál a makród, de ezek a címzések picit bonyolultnak tűnnek a range-k-hez...

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