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

• #32553 Delila_1 veterán Zozzy #32552

  Új Válasz 2016-09-02 06:59:15 #32553

  Ú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 Zozzy #32552 üzenetére

  3 makrót írtam. Az első sorra veszi a B oszlop celláit. Ha még nincs ennek megfelelő lap a füzetben, létrehozza, átmásolja a címsort és az aktuális sort. Az új lap neve az aktuális sor B oszlopában lévő adat lesz. Ha már van ilyen nevű lap, az első üres sorába másolja az aktuális sort. Nem kell az első lapon rendezettnek lennie a táblának.

  A második sorra veszi a lapokat a másodiktól az utolsóig, Új füzetbe másolja az aktuális lapot, ezt elmenti a lapnév nevével az utvonal nevű változóban megadott mappába. Ezt a makró elején kell átírnod az
  utvonal = "C:\Temp\"
  sorban a saját mentési útvonaladra.

  Ha az eredeti füzetben nem akarod megtartani az újonnan létrehozott lapokat, akkor a második helyett a harmadik makrót futtasd. Ez nem másolja, hanem áthelyezi a lapokat 1-1 új füzetbe. Itt is át kell írnod az utvonal változó értékét.

  A két másolós makró feltételezi, hogy kezdetkor 1 lap volt a füzetedben.

  Sub Kulon_Lapra()
Dim sor As Long, lapnev As String, a, hova As Long, WS1 As Worksheet

Application.ScreenUpdating = False
Set WS1 = ActiveSheet
sor = 2
Do While Cells(sor, 1) <> ""
lapnev = Cells(sor, "B")
On Error Resume Next
Set a = Sheets(lapnev)
If Err.Number <> 0 Then
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = lapnev
WS1.Rows(1).Copy Sheets(lapnev).Cells(1)
WS1.Activate
End If
On Error GoTo 0

hova = Application.WorksheetFunction.CountA(Sheets(lapnev).Columns(1)) + 1
Rows(sor).Copy Sheets(lapnev).Cells(hova, 1)
sor = sor + 1
Loop
Application.ScreenUpdating = True
End Sub

  Sub LapMentes()
Dim lap As Long, utvonal As String, lapnev As String
utvonal = "C:\Temp\"

Application.ScreenUpdating = False
For lap = 2 To Sheets.Count
lapnev = Sheets(lap).Name
Sheets(lapnev).Copy
ActiveWorkbook.SaveAs Filename:=utvonal & lapnev & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub

  Sub MentTorol()
Dim lap As Long, utvonal As String, lapnev As String
utvonal = "C:\Temp\"

Application.ScreenUpdating = False
For lap = Sheets.Count To 2 Step -1
lapnev = Sheets(lap).Name
Sheets(lapnev).Move
ActiveWorkbook.SaveAs Filename:=utvonal & lapnev & ".xlsx"
ActiveWorkbook.Close
Next
Application.ScreenUpdating = True
End Sub

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