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

• #13584 Delila_1 veterán zhari #13544

  Új Válasz 2012-04-26 10:52:18 #13584

  Ú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 zhari #13544 üzenetére

  Ez a makró megcsinálja. Előbb új lapokra másolja az egyes sorokat, mindegyiket olyan nevű lapra, amilyen adatot tartalmaz az adott sor első (A) cellája.
  Ezután az egyes lapokat áthelyezi 1-1 új fájlba, aminek a neve a lapnév + "_adott adat".

  Az utvonal = "E:\Eadat\" sorban írd át az útvonalat a sajátodra, a végén is legyen \ jel, mint itt.
  A nev$ = utvonal & Sheets(1).Name & "_adott adat.xls" sor végén az .xls helyett írj .xlsx-et, ha 2003-asnál magasabb verziót alkalmazol.

  Címsort feltételezek, ezért az első ciklust (sorok másolása másik lapokra) a 2. sortól kezdtem a For sor% = 2 To usor% sorban. Címsor nélkül legyen ez a sor For sor% = 1 To usor%.

  Sub Ujak()
  Dim sor%, usor%, usor_1%, nev$, WS1 As Worksheet
  Dim utvonal$, lap%
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  
  utvonal = "E:\Eadat\" 'Itt írd be a saját útvonaladat ehelyett
  usor% = Cells(Rows.Count, "A").End(xlUp).Row
  Set WS1 = Sheets("Kezdőlap")
  
  For sor% = 2 To usor%
  nev$ = WS1.Cells(sor%, "A")
  On Error GoTo Uj_lap
  usor_1% = Sheets(nev$).Cells(Rows.Count, "A").End(xlUp).Row + 1
  WS1.Rows(sor%).Copy Sheets(nev$).Cells(usor_1%, "A")
  Next
  
  
  For lap% = 1 To Sheets.Count - 1
  nev$ = utvonal & Sheets(1).Name & "_adott adat.xls"
  Sheets(1).Move
  
  ActiveWorkbook.SaveAs Filename:=nev$, FileFormat:=xlNormal _
  , Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
  CreateBackup:=False
  ActiveWindow.Close
  Next
  
  Application.ScreenUpdating = True
  Application.DisplayAlerts = True
  MsgBox "Kész"
  Exit Sub
  
  Uj_lap:
  If Err = 9 Then
  Worksheets.Add.Name = nev$
  Resume 0
  Else
  Error Err
  End If
  
  End Sub

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