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

• #34064 poffsoft veterán Fferi50 #34063

  Új Válasz 2017-02-04 23:43:58 #34064

  Ú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

  

  poffsoft

  veterán

  válasz Fferi50 #34063 üzenetére

  o.k.
  Fránya makrórögzítő csak így hajlandó rögzíteni.

  ráadásul a "H" még hibás is volt, csak most vettem észre:

  Sub Rendez()

Dim usor As Long
Dim lusor As Long
Dim ms As Long ' max sor'
Dim sm As Long ' aktualis sor'
Dim i As Variant
Dim Ls() As String
Dim Ts As String
Dim valasz As String

Ls() = Split("B.C.D.E", ".") ' a neveket tartalmazó oszlopok'
Ts = "H" ' a szűrt lista oszlopa'
sm = 1
ms = Rows.Count

usor = Range(Ts & ms).End(xlUp).Row
If usor > 1 Then
valasz = MsgBox("Nem üres a cél """ & Ts & """ oszlop." & vbCrLf & "Folytatod?", vbYesNo, "Figyelem!")
If valasz = vbYes Then Range(Ts & "1:" & Ts & usor).Clear Else Exit Sub
End If

For Each i In Ls
usor = Range(i & ms).End(xlUp).Row
If usor > 1 Then
Range(i & "2:" & i & usor).Copy Destination:=Range(Ts & sm)
sm = sm + usor - 1
End If
Next i

'duplicate remove'

usor = Range(Ts & ms).End(xlUp).Row
Application.DisplayAlerts = False
Range(Ts & "1:" & Ts & usor).RemoveDuplicates Columns:=1, Header:=xlNo
Application.DisplayAlerts = True
With ActiveSheet.Sort
.SetRange Range(Ts & "1:" & Ts & usor)
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range(Ts & "1").Select

End Sub

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