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

• #31033 Delila_1 veterán Fferi50 #31032

  Új Válasz 2016-03-16 09:38:46 #31033

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

  Igen, ez egy másik felfogása a feladatnak. Megírtam ezt is. A futási idők különbsége csak sok sor esetén mérhető, én mindössze 20 sorral dolgoztam.

  Nem tudjuk, hány oszlop van az Eredeti lapon. A makróban az A:K tartományt vettem alapul, amit két helyen kell módosítani, a csillagokkal jelzett sorokban.

  Szerk.: az A:K tartományra történő hivatkozást is át lehetne állítani a makróban, de azt már nem írom meg.

  Sub Kulcsok()
  Dim usor As Long, usor1 As Long, lap As String, sor As Long, lapnev
  
  With Sheets("Eredeti")
  .Range("AA:AN").ClearContents
  .Range("AA1") = .Range("C1")
  .Range("AB1") = .Range("AA1")
  .Range("A1:K1").Copy .Range("AD1") '*****
  
  usor = .Range("C" & Rows.Count).End(xlUp).Row
  .Range("C1:C" & usor).AdvancedFilter Action:=xlFilterCopy, _
  CopyToRange:=.Range("AA1"), Unique:=True
  
  usor1 = .Range("AA" & Rows.Count).End(xlUp).Row
  
  For sor = 2 To usor1
  .Cells(2, "AB") = .Cells(sor, "AA")
  
  '*****
  .Range("A1:K" & usor).AdvancedFilter Action:=xlFilterCopy, _
  CriteriaRange:=.Range("AB1:AB2"), _
  CopyToRange:=.Range("AD1:AN1"), Unique:=False
  
  lap = .Range("AB2") & ""
  
  On Error Resume Next
  Set lapnev = Sheets(lap)
  If Err.Number <> 0 Then
  Sheets.Add Before:=Sheets(Sheets.Count)
  ActiveSheet.Name = lap
  On Error GoTo 0
  Else
  Sheets(lap).Cells.ClearContents
  End If
  
  .Range("AD1").CurrentRegion.Copy Sheets(lap).Range("A1")
  Next
  End With
  
  Beep
  MsgBox "Kész van.", vbInformation
  End Sub

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