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

• #18606 Delila_1 veterán bandus #18605

  Új Válasz 2013-07-24 14:25:28 #18606

  Ú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

  veterán

  válasz bandus #18605 üzenetére

  A gyűjtő füzetben arra a lapra, ahova be akarod gyűjteni az adatokat, tegyél ki 2 választó kapcsolót.
  A nevük legyen Utvonal1 és Utvonal2. Ehhez a laphoz rendeld az első makrót.

  Private Sub Utvonal1_Change()
  Dim utvonal As String
  If Utvonal1 Then utvonal = "C:\Elso utvonal\" Else utvonal = "C:\Masodik utvonal\"
  TobbFuzetbe utvonal
  End Sub

  A saját útvonalaidat írd be hozzájuk.

  Modulba jön a második makró.

  Sub TobbFuzetbe(utvonal)
  Application.ScreenUpdating = False 'Képernyőfrissítés letiltása
  Application.DisplayAlerts = False 'Kérdések letiltása
  
  'Helyfoglalás
  Dim usor, FN, WBGy As Workbook, WBU As Workbook, WSGy As Worksheet, WSU As Worksheet
  'Értékadás
  Set WBGy = ActiveWorkbook 'Gyűjtő füzet
  Set WSGy = WBGy.Sheets(1) 'Gyűjtőnek az a lapja, ahova másolni kell
  ChDir utvonal 'Direktor váltás
  FN = Dir(utvonal & "*.xls", vbNormal)
  Do
  If FN <> "." And FN <> ".." Then
  'Fájlok behívása
  Workbooks.Open Filename:=utvonal & FN
  Set WBU = ActiveWorkbook 'utvonal-ról behívott füzet
  Set WSU = WBU.Sheets(1) 'behívott füzet lapja, ahonnan másolsz
  
  WSU.Visible = True 'láthatóság engedélyezése
  WSU.Activate 'ez legyen az aktív lap
  
  'első üres sor a gyűjtő füzetben
  usor = WSGy.Range("A" & Rows.Count).End(xlUp).Row + 1
  
  Range("A1:A25").Copy WSGy.Range("A" & usor) 'másolás
  
  ActiveWindow.Close False 'behívott fájl bezárása módosítás nélkül
  End If
  FN = Dir()
  Loop Until FN = ""
  
  Application.DisplayAlerts = True 'Kérdések engedélyezése
  Application.ScreenUpdating = True 'Képernyőfrissítés engedélyezése
  End Sub

  A sorokhoz írtam magyarázatot.

  Mindegyik füzetben az első lapot vittem be a Set utasításokban, de ezen változtathatsz.
  Set WSGy = WBGy.Sheets(1)
  Set WSU = WBU.Sheets(1)

  Az 1-es érték helyére a füzetben elfoglalt helyzetüket add meg.

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