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

• #38484 föccer nagyúr

  Új Válasz 2018-07-06 14:00:39 #38484

  Ú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

  

  föccer

  nagyúr

  Sziasztok!

  Makro segítséget kérek.

  Van egy táblázatom, amibe autoszűrűvel beállítom a szükséges paramétereket.

  A Mintavételek fülön van, az autoszűrő a 6 sorban van beállítva, az adattábla ez alatti sorokban

  Munka1 segédtáblázatra kellene kitennem az szűrt táblázat E oszlopából a leszűrt elemeket, a Munka 1 A1 cellájától kezdődően, majd B1-be beszúrva eltávolítom az ismétlődéseket, majd az egyedi értékeket átmásolnám a J oszlopba.

  A többi lépés majd ez után jön. A problám az, hogy a kód nem illeszti be az összes szűrt elemet a mintavétel munkalapról, csak a legelsőt.

  Hol a hiba?

  Köszi

  Sub Szilardsagi_elemzes_masolas()

Dim i, j, sor, k As Integer


'---------------------------------------- Előzmények törlése

Sheets("Munka1").Select
activesheets.Columns("A:A").Select
Selection.ClearContents
activesheets.Columns("B:B").Select
Selection.ClearContents
activesheets.Columns("J:J").Select
Selection.ClearContents
For k = 1 To 150
Sheets("Munka1").Range("K" & k).Formula = "=COUNTIFS(C[-10],RC[-1])"
End


'---------------------------------------- receptszámok átmásolása, válogatása

Sheets("Mintavételek").Select
For sor = 7 To 100000
If Rows(sor).Hidden = False Then
Range("E" & sor).Select
Range(Selection, Selection.End(x1Down)).Select
Selection.Copy
End If
End
Sheets("Munka1").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Sheets("Munka1").Range("B1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False

ActiveSheet.Range("$B$1:$B$1000").RemoveDuplicates Columns:=1, Header:=xlNo
Range("B1").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlDown)).Select
Selection.Copy
Range("J1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

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