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

• #32566 Delila_1 veterán Zozzy #32565

  Új Válasz 2016-09-02 17:45:56 #32566

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

  Van megoldás.

  Sub Kulon_Lapra_2()
Dim sor As Long, lapnev As String, WS1 As Worksheet, usor As Long

Application.ScreenUpdating = False
Set WS1 = ActiveSheet

'egyedi rekordok az AA oszlopba
WS1.Range("B1:B" & Application.CountA(WS1.Columns(2))).AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("AA1"), Unique:=True

sor = 2
Do While Cells(sor, "AA") <> ""
lapnev = Cells(sor, "AA")

WS1.Range("A1").CurrentRegion.AutoFilter Field:=2, Criteria1:=lapnev 'szűrés

Sheets.Add After:=Sheets(Sheets.Count) 'új lap létrehozása
ActiveSheet.Name = lapnev

WS1.Range("A1").CurrentRegion.Copy Sheets(lapnev).Cells(1) 'másolás
'képlet az U:W-be
usor = Application.WorksheetFunction.CountA(Columns(22)) + 1
Range("U" & usor & ":W" & usor) = "=subtotal(9,U2:U" & usor - 1 & ")"

WS1.Activate
sor = sor + 1
Loop
WS1.Range("A1").CurrentRegion.AutoFilter Field:=2 'szűrő visszaállítása
Application.ScreenUpdating = True
End Sub

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