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

• #4439 Delila_1 veterán Gabcsika #4436

  Új Válasz 2009-02-02 08:42:47 #4439

  Ú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 Gabcsika #4436 üzenetére

  Nagy nehezen megszületett.

  Sub Egyezo()
  Sheets("Sheet1").Select
  
  '******* Rendezés ***************
  Range("A2").Select
  Selection.Sort Key1:=Range("A2"), Order1:=xlAscending, Key2:=Range("B1") _
  , Order2:=xlAscending, Header:=xlGuess, OrderCustom:=1, MatchCase:= _
  False, Orientation:=xlTopToBottom
  '************************************
  
  sor_1 = 1: sor_2 = 1
  Sheets("Sheet2").Select
  
  Do
  első = sor_1
  A = Cells(sor_2, 1)
  Sheets("Sheet1").Select
  Do While Cells(sor_1, 1) <> ""
  If Cells(sor_1, 1) = A Then
  If Cells(sor_1 + 1, 1) > A Or Cells(sor_1 + 1, 1) = "" Then
  ucsó = sor_1
  Range("B" & első & ":B" & ucsó).Select
  ActiveWorkbook.Names.Add Name:="tartomány", RefersTo:=Selection
  
  Sheets("Sheet2").Select
  Cells(sor_2, 2).Select
  Selection.FormulaR1C1 = "=SUMPRODUCT((tartomány<>"""")/COUNTIF(tartomány,tartomány))"
  Selection.Copy
  Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, _
  SkipBlanks:=False, Transpose:=False
  Sheets("Sheet1").Select
  ActiveWorkbook.Names("tartomány").Delete
  sor_1 = sor_1 + 1
  Exit Do
  End If
  End If
  sor_1 = sor_1 + 1
  Loop
  sor_2 = sor_2 + 1
  Sheets("Sheet2").Select
  Loop While Cells(sor_2, 1) <> ""
  Application.CutCopyMode = False
  
  End Sub

  A csillagokkal határolt rész a Sheet1-en való rendezés. Nálam nincs rovatfej. Ha ez nem jó, helyette rögzítsd makróban a kétkulcsos rendezést, első kulcs az A, második a B oszlop, emelkedő sorrendben.

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