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

• #36042 Fferi50 őstag n1nja #36041

  Új Válasz 2017-08-25 15:36:19 #36042

  Ú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

  

  Fferi50

  őstag

  válasz n1nja #36041 üzenetére

  Szia!

  Az alábbi makró az Excel sajátos eszközeivel próbálja megoldani a problémát (több segédtartományra is szüksége van, amit az elején definiálok).

  Sub rendezi()
Dim rng1 As Range, rng2 As Range, rng3 As Range, rng4 As Range, sora As Integer, sor As Integer
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set rng1 = Range("A1").CurrentRegion
Set rng2 = Range("AA1")
Set rng3 = Range("Q1:Q2"): rng3.Cells(1).Value = "Gép"
Set rng4 = Range("U1")
rng1.Copy Destination:=rng2
Set rng2 = rng2.CurrentRegion
rng1.Offset(1, 0).ClearContents
sor = 2
Do
rng1.Cells(sor, 2).Value = Application.Small(rng2.Columns(2).Offset(1, 0), 1)
sora = Application.Match(rng1.Cells(sor, 2), rng2.Columns(2), 0)
rng3.Cells(2, 1).Value = rng2.Cells(sora, 1).Value
rng2.AdvancedFilter Action:=xlFilterCopy, criteriarange:=rng3.Columns(1), copytorange:=rng4, unique:=False
rng4.Sort key1:=rng4.Cells(1, 2), order1:=xlAscending, Header:=xlYes
rng4.Cells(1, 1).CurrentRegion.Offset(1, 0).Copy Destination:=rng1.Cells(sor, 1)
sor = rng1.End(xlDown).Row + 1
rng2.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=rng3.Columns(1), unique:=False
rng2.SpecialCells(xlCellTypeVisible).ClearContents
rng1.Rows(1).Copy rng2.Rows(1)
rng2.AdvancedFilter Action:=xlFilterInPlace, criteriarange:=rng3.Cells(1), unique:=False
rng4.CurrentRegion.ClearContents
If Application.CountA(rng2) = 4 Then Exit Do
Loop
rng3.CurrentRegion.ClearContents
rng2.CurrentRegion.ClearContents
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
MsgBox "Kész van", vbInformation
End Sub

  Üdv.

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