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

• #47864 Fferi50 őstag ny.erno #47863

  Új Válasz 2021-11-24 11:06:30 #47864

  Ú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 ny.erno #47863 üzenetére

  Szia!
  Én az egyik futásnál ellenőriztem, hogy megvan-e mind a kétszázezer szám (ismétlődések összeadva + az egyedi) pontosan megvolt.
  A pivottáblás makró, feltételek:
  Első futtatásnál:
  Csak 1 munkalap legyen a munkafüzetben, amelyiknek az A oszlopában ott vannak a számok. A1 cella fejléc.
  Ekkor a makró létrehoz egy nevet - forras - a névkezelőben, ami beállítja a pivot forrását
  Ezután létrehoz egy új munkalapot, arra a pivottáblát.
  Az új D1 cellájától kezdve átmásolja a pivot eredményét.
  Szűri 1 -re (azaz egyediek) - átmásolja az első munkalap D oszlopába
  Szűri >1-re (azaz ismétlődők) - átmásolja az első munkalap F oszlopába
  Ez kb. fél perc 200000 tételnél.
  Ha a továbbiakban a változások kezelésére is ezt szeretnéd használni, akkor nincs más teendő, mint az új sorozatszámokat hozzáírni/felülírni az első munkalap A oszlopában, majd jöhet a
  második/sokadik futtatás
  Fontos! Ebben az esetben is az első munkalapon kell állnod, amikor a makrót indítod.
  Az előző futás eredménye felülíródik a D és F oszlopokban.
  Íme a makró:
  Sub tablas()
Dim sh1 As Worksheet, sh2 As Worksheet, pvt As PivotTable, tblsource As String, pvtfname As String, nm As Name
Application.ScreenUpdating = False
Set sh1 = ActiveSheet: pvtfname = sh1.Range("A1").Value
If Names.Count > 0 Then
Set nm = Names("forras")
End If
If nm Is Nothing Then Set nm = ActiveWorkbook.Names.Add(Name:="forras", RefersTo:="=OFFSET(" & sh1.Name & "!$A$1,0,0,COUNTA(" & sh1.Name & "!$A$1:$A$300000),1)")
If Sheets.Count = 1 Then
Set sh2 = ActiveWorkbook.Sheets.Add(after:=sh1)
Else
Set sh2 = Sheets(2)
End If
tblsource = Replace(Evaluate(Names("forras").RefersTo).Address(ReferenceStyle:=xlR1C1, external:=True), "[" & sh2.Parent.Name & "]", "")
If sh2.PivotTables.Count = 0 Then
Set pvt = sh1.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=tblsource, Version:=6).CreatePivotTable(tabledestination:=Replace(sh2.Range("A1").Address(ReferenceStyle:=xlR1C1, external:=True), "[" & sh2.Parent.Name & "]", ""), TableName:="Srszamok", Defaultversion:=6)
pvt.AddDataField pvt.PivotFields(pvtfname), "Darabszám", xlCount
pvt.PivotFields(pvtfname).Orientation = xlRowField
Else
Set pvt = sh2.PivotTables(1)
pvt.RefreshTable
End If
With sh2.Range("D1")
If .Value <> "" Then .CurrentRegion.ClearContents
If sh1.Range("D1").Value <> "" Then sh1.Range("D1").CurrentRegion.ClearContents
If sh1.Range("F1").Value <> "" Then sh1.Range("F1").CurrentRegion.ClearContents
.Resize(rowsize:=pvt.TableRange1.Rows.Count, columnsize:=pvt.TableRange1.Columns.Count).Value = pvt.TableRange1.Value
With .CurrentRegion
.AutoFilter field:=2, Criteria1:="1"
.Columns(1).SpecialCells(xlCellTypeVisible).Copy Destination:=sh1.Range("D1")
.AutoFilter field:=2, Criteria1:=">1"
.Columns(1).SpecialCells(xlCellTypeVisible).Copy Destination:=sh1.Range("F1")
.AutoFilter field:=2
End With
End With
sh1.Range("D1").Value = "Egyedi": sh1.Range("F1").Value = "Ismétlődő"
sh1.Activate
ActiveWindow.ScrollRow = 1
Range("D1").Select
MsgBox "Készen vagyunk!"
Application.ScreenUpdating = True
End Sub
  Üdv.

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