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

• #28661 poffsoft addikt 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

  addikt

  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...

  [ Szerkesztve ]

  [ Szerkesztve ]

• #28662 Delila_1 Topikgazda szőröscica #28660

  Új Válasz 2015-09-16 19:16:34 #28662

  Ú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

  Topikgazda

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

  Nem kell külön beolvastatni a fájlneveket, majd másolni, végül törölni a felesleges sorokat. Az alábbi makró mindegyik műveletet elvégzi.

  Két dolgot kell átírnod benne, az útvonalat, ahonnan a fájlokat behívod, és a kiterjesztést, ha 2007-es verziónál régebbi Excelt használsz.

  Sub Osszemasolas()
  Dim FN As String, utvonal As String, WS As Worksheet
  Dim hova As Long, tabla As Range, CV As Object
  
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set WS = ActiveWorkbook.ActiveSheet
  utvonal = "F:\Eadat\Tmp\" 'fájlok útvonala, írd át
  FN = Dir(utvonal & "*.xlsx") '2007-es előtti verziónál xls-re írd át
  
  Do While FN <> ""
  hova = Application.WorksheetFunction.CountA(Columns(1)) + 1
  Workbooks.Open utvonal & FN
  Sheets("Data").Select
  
  Range("A1").Select
  Set tabla = Cells.CurrentRegion
  tabla.Offset(1, 0).Resize(tabla.Rows.Count - 1, tabla.Columns.Count).Copy
  
  WS.Cells(hova, "A").PasteSpecial Paste:=xlPasteAll
  
  Windows(FN).Close False 'Zárja a megnyitott fájlt mentés nélkül
  
  For Each CV In Selection
  If CV = "q" Or CV = "r" Then Rows(CV.Row).Delete
  Next
  FN = Dir()
  Loop
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  
  MsgBox "Kész", vbInformation
  End Sub

  Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

• #28663 Delila_1 Topikgazda szőröscica #28660

  Új Válasz 2015-09-16 19:32:46 #28663

  Ú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

  Topikgazda

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

  Kicsit gyorsítva az előbbi (törli a sorokat, ahol bármelyik oszlopban szerepel a q vagy az r):

  Sub Osszemasolas()
  Dim FN As String, utvonal As String, WS As Worksheet
  Dim hova As Long, WF As WorksheetFunction, vege As Long, sor As Long
  Dim tabla As Range
  
  Application.Calculation = xlCalculationManual
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  Set WS = ActiveWorkbook.ActiveSheet
  Set WF = Application.WorksheetFunction
  utvonal = "F:\Eadat\Tmp\" 'fájlok útvonala, írd át
  FN = Dir(utvonal & "*.xlsx") '2007-es előtti verziónál xls-re írd át
  
  Do While FN <> ""
  hova = WF.CountA(Columns(1)) + 1
  Workbooks.Open utvonal & FN
  Sheets("Data").Select
  
  Range("A1").Select
  Set tabla = Cells.CurrentRegion
  tabla.Offset(1, 0).Resize(tabla.Rows.Count - 1, tabla.Columns.Count).Copy
  
  WS.Cells(hova, "A").PasteSpecial Paste:=xlPasteAll
  
  Windows(FN).Close False 'Zárja a megnyitott fájlt mentés nélkül
  
  vege = WF.CountA(Columns(1))
  For sor = hova To vege
  If WF.CountIf(Rows(sor), "q") > 0 Or WF.CountIf(Rows(sor), "r") > 0 Then
  Rows(sor).Delete shift:=xlUp
  End If
  Next
  
  FN = Dir()
  Loop
  
  Application.Calculation = xlCalculationAutomatic
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  
  MsgBox "Kész", vbInformation
  End Sub

  [ Szerkesztve ]

  Programozó: hibás programok megírására és kijavítására kiképzett szakember. Többet ésszel, mint ész nélkül.

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