Hirdetés

2024. május 4., szombat

Lapcsaládunk:

Gyorskeresés

Legfrissebb anyagok

Általános témák

LOGOUT.hu témák

Szakmai témák

PROHARDVER! témák

Mobilarena témák

IT café témák

GAMEPOD.hu témák

Útvonal

Fórumok  »  OS, alkalmazások  »  Microsoft Excel topic (kiemelt téma)

Téma összefoglaló

Téma összefoglaló

  • Utoljára frissítve: 2023-11-13 08:31:56

LOGOUT.hu

A Microsoft Excel topic célja segítséget kérni és nyújtani Excellel kapcsolatos problémákra.
Kérdés felvetése előtt olvasd el, ha még nem tetted.

Összefoglaló kinyitása ▼

Hozzászólások

(#31034) Fferi50 válasza Delila_1 (#31033) üzenetére


Fferi50
őstag

Szia!

Nekem ez "sikeredett" mostanra:
Sub szuroget()
Dim sh1 As Worksheet, sh2 As Worksheet, usor As Integer, xx As Integer, szuro As Range, cel As Range, szurni As Range
Set sh1 = ActiveSheet
Set szuro = sh1.Range("BB1:BB2")
Set szurni = sh1.Cells(1).CurrentRegion
szuro.Clear
szuro.Cells(1, 0).Clear
szurni.Columns("Q").AdvancedFilter Action:=xlFilterCopy, criteriarange:=sh1.Range("Q1"), copytorange:=szuro.Cells(1, 0), unique:=True
szuro.Cells(1).Value = szuro.Cells(1, 0).Value
usor = szuro.Cells(1, 0).End(xlDown).Row
For xx = 2 To usor
szuro.Cells(2).Value = szuro.Cells(xx, 0).Value
On Error Resume Next
Set sh2 = Sheets(szuro.Cells(2).Value)
If Err <> 0 Then
Set sh2 = Sheets.Add(after:=Sheets(Sheets.Count))
sh2.Name = szuro.Cells(2).Value
Else
sh2.UsedRange.Clear
End If
Set cel = sh2.Range("A1")
szurni.AdvancedFilter Action:=xlFilterCopy, criteriarange:=szuro, copytorange:=cel, unique:=False
Next
sh1.Activate
End Sub

Üdv.

Útvonal

Fórumok  »  OS, alkalmazások  »  Microsoft Excel topic (kiemelt téma)

Támogatóink

Copyright © 2000-2024 PROHARDVER Informatikai Kft.