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

• poffsoft veterán

  #28661

  #28660 szőröscica

  2015-09-16 19:11:04

  Új Válasz

  Ú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

  

  poffsoft

  veterán

  #28660 szőröscica

  #28660 szőröscica

  Sziasztok!

  Van egy makróm, amit arra használok, hogy egy mappában szereplő összes xls tartalmát behúzza egyetlen sheetre. Először egy másik makróval kilistáztatom az összes fájlt ami az adott mappában van, majd futtatom az alul találhatót.

  Tudnátok segíteni abban, hogy hogyan tudnám módosítani olyan módon, hogy miután egy fájlból bemásolta az összes sort, törölje ki azokat a sorokat, amiknek bármelyik (vagy ha így nem lehet, akkor I és M oszlopban) cellájában q vagy r szerepel.

  Azért lenne erre szükségem, mert 16-17 ezer sorosak a fájlok, amiket importál a makró, viszont mindegyiknek körülbelül harmadában szerepel q vagy r érték, amelyek számomra haszontalan adatok, így rengeteg helyet spórolhatnak (közel vagyok az 1 millió sorhoz, és ha azt túllépem, nem másolja tovább a makró dolgokat).

  Az alábbi makrót használom az importálásra. Segítenétek módosítani?

  Köszönöm szépen.

  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
  
  
  
  ' 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
  Application.CutCopyMode = False
  
  Workbooks(files).Activate
  ActiveWorkbook.Close
  
  
  Next i
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  
  
  End Sub

  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