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

• #41626 Delila_1 veterán MasterMark #41625

  Új Válasz 2019-08-20 16:22:53 #41626

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

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

'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
ujnev = Application.WorksheetFunction.Substitute(lapnev, " ", "")
ujnev = Left(ujnev, 30)
Sheets.Add.Name = ujnev
Sheets("Munka1").Select
Rows("1:2").Copy Sheets(ujnev).Range("A1")
innen = sor
eddig = Application.WorksheetFunction.Match(lapnev, Columns(10), 1)
ide = Sheets(ujnev).Range("A" & Rows.Count).End(xlUp).Row + 1
Range("A" & innen & ":J" & eddig).Copy Sheets(ujnev).Range("A" & ide)
Sheets(ujnev).Range("A1") = ujnev
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