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

• #21859 zhari csendes tag

  Új Válasz 2014-06-04 09:50:50 #21859

  Ú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

  

  zhari

  csendes tag

  Sziasztok!

  Végső célom az, hogy egy adott mappa almappáiból meghatározott nevű "cica_*.xlsx"-ek (* természetesen változik) állandó munkalapnevű (munka1) lapokról adott tartományokat egy új táblába egymás alá szeretnék másolni.
  Van pár elvileg működő script amiket szeretnék egyesíteni, de nem jön össze.

  Sub makrófuttatás_almappákban()
  Dim lCount As Long
  Dim wbResults As Workbook
  Dim wbCodeBook As Workbook

  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.EnableEvents = False

  On Error Resume Next
  Set wbCodeBook = ThisWorkbook
  With Application.FileSearch
  .NewSearch
  'Change path to suit
  .LookIn = "C:\...\egyéb\makrók\teszt"
  .FileType = msoFileTypeExcelWorkbooks
  .SearchSubFolders = True
  'Optional filter with wildcard
  '.Filename = "cica*.xls"
  If .Execute > 0 Then 'Workbooks in folder
  For lCount = 1 To .FoundFiles.Count 'Loop through all
  'Open Workbook x and Set a Workbook variable to it
  Set wbResults = Workbooks.Open(filename:=.FoundFiles(lCount), UpdateLinks:=0)

  'DO YOUR CODE HERE
  Range("A1").Select
  ActiveCell.FormulaR1C1 = "=2"

  wbResults.Close savechanges:=False
  Next lCount
  End If
  End With
  On Error GoTo 0
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  Application.EnableEvents = True
  MsgBox "kész"
  End Sub

  A fentivel az a bajom, hogy nem tudom meghatározni, hogy milyen nevű táblákkal dolgozzon és mintha nem jó táblákon indítaná a makrót.

  Egy másik script ugyanerre:

  Sub makrófuttatás_almappákban()
  Dim folderPath As String
  Dim filename As String
  Dim wb As Workbook

  folderPath = "C:\...\egyéb\makrók\teszt" 'change to suit

  If Right(folderPath, 1) <> "" Then folderPath = folderPath + ""

  filename = Dir(folderPath & "cica2*.xls")
  Do While filename <> ""
  Application.ScreenUpdating = False
  Set wb = Workbooks.Open(folderPath & filename)

  'Call a subroutine here to operate on the just-opened workbook
  Range("A1").Select
  ActiveCell.FormulaR1C1 = "=2"
  filename = Dir
  Loop
  Application.ScreenUpdating = True
  MsgBox "kész", vbInformation
  End Sub

  A fentiek valamelyikét szeretném egyesíteni a következő scripptel.

  Sub Fésü()
  Const utvonal = "C:\...\egyéb\makrók\teszt" 'Ezt írd át arra a mappára, ahol az xls-eid vannak
  Dim FN As String, WB As Workbook

  ChDir utvonal
  FN = Dir(utvonal & "D01_*.xls", vbNormal)
  Do
  If FN <> "." And FN <> ".." Then
  Workbooks.Open Filename:=FN
  usor = Range("A65536").End(xlUp).Row 'Behívott füzet alsó sora

  Windows("02.xlsx").Activate
  gy_usor = Range("A65536").End(xlUp).Row 'Gyűjtő füzet alsó sora

  Windows(FN).Activate 'Behívott füzet
  Range(Cells(1, 1), Cells(usor, 12)).Copy 'A oszlop (1:4)

  Windows("02.xlsx").Activate 'Gyűjtő füzet
  Cells(gy_usor, 1).Select
  ActiveSheet.Paste
  Windows(FN).Activate 'Behívott füzet

  ActiveWorkbook.Save
  ActiveWindow.Close
  End If
  FN = Dir()
  Loop Until FN = ""
  End Sub

  Remélem érthető volt a problémám. Minden hozzászólást szívesen fogadok.

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