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

• #31034 Fferi50 Topikgazda Delila_1 #31033

  Új Válasz 2016-03-16 09:50:55 #31034

  Ú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

  Topikgazda

  válasz Delila_1 #31033 üzenetére

  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.

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