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

• #41624 Delila_1 veterán MasterMark #41623

  Új Válasz 2019-08-20 15:28:24 #41624

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

  Modulba másold a lenti makrót (lásd a Téma összefoglalóban). A makróban a Munka1 nevet mindenhol írd át a saját lapod nevére.

  Sub Szortirozas()
Dim usor As Long, sor As Long, lapnev As String
Dim innen As Long, eddig As Long, ide As Long

'Rendezés album szerint
Sheets("Munka1").Select
usor = Range("A" & Rows.Count).End(xlUp).Row
ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(1).Sort.SortFields.Add2 Key:=Range("J3:J" & usor), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(1).Sort
.SetRange Range("A1:J" & usor)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With

'Másolás új lapokra
sor = 3
Do While Cells(sor, 10) <> ""
lapnev = Cells(sor, 10)
If Application.WorksheetFunction.CountIf(Columns(10), lapnev) > 1 Then
Sheets.Add.Name = lapnev
Sheets("Munka1").Select
Rows("1:2").Copy Sheets(lapnev).Range("A1")
innen = sor
eddig = Application.WorksheetFunction.Match(lapnev, Columns(10), 1)
ide = Sheets(lapnev).Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & innen & ":J" & eddig).Copy Sheets(lapnev).Range("A" & ide)
Sheets(lapnev).Range("A1") = lapnev
sor = eddig + 1
Else
sor = sor + 1
End If
Loop

Sheets("Munka1").Move Before:=Sheets(1)
MsgBox "Kész van az albumonkénti szortírozás", vbInformation, "Információ"
End Sub

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