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

• #21251 Delila_1 veterán user112 #21248

  Új Válasz 2014-04-12 10:48:24 #21251

  Ú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 user112 #21248 üzenetére

  A Munka1 lapon elvégzi a makró a kigyűjtést a K oszloptól kezdődően, majd a kigyűjtött tatrományt áthelyezi a Munka2 lap A2 cellájától kezdve. A Munka2 lap címsorát egyszer kell beírni.

  A makróban többször szerepel a két lap neve, ezeket írd át a saját lapjaid nevére.

  Sub valami()
  Dim sor As Long, usor As Long, ertek As String, jel As String
  Dim sor1 As Long
  
  Sheets("Munka1").Select
  usor = Range("A" & Rows.Count).End(xlUp).Row
  
  'A oszlop adatainak másolása az K oszlopba
  Range("A2:A" & usor).Copy Range("K1")
  
  'Ismétlődések eltávolítása a K oszlopból
  ActiveSheet.Range("$K$1:$K$" & usor - 1).RemoveDuplicates Columns:=1, Header:=xlNo
  
  For sor = 2 To usor
  ertek = Cells(sor, "A")
  jel = Cells(sor, "F")
  sor1 = Application.WorksheetFunction.Match(ertek, Columns(11), 0)
  Cells(sor1, Cells(sor1, Columns.Count).End(xlToLeft).Column + 1) = jel
  Next
  
  'Munka2 lapon előző adatok törlése
  Sheets("Munka2").Range("A2:Z5000") = ""
  
  'Kigyűjtött adatok kivágása és másolása a Munka2 lap A2 cellájába
  Range("K1").Select
  Selection.CurrentRegion.Cut Sheets("Munka2").Range("A2")
  
  Sheets("Munka2").Activate
  End Sub

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