Makro - Excel

[Taps]

Zdravím, v excelu mám vytvořený report a potřeboval bych poradit jak vytvořit makro, které mi na novém listě v prvním sloupečku zobrazí uživatel ( v přiloze uvedeno modrou barvou) a vedle nich bude zobrazeno číslo (v příloze uvedeno červenou barvou).Ideální by ještě bylo kdyby data byla seřazena sestupně podle udaje v druhém sloupečku. Testovací data jsou uvedeny v příloze. Ještě podotknu že uživatelů je více jak 100 a každý může mít uveden neomezeny počet stranek.

priloha(2).zip

(2.4 KiB) Staženo 65 x

Děkuji

[navstevnik]

Za predpokladu, ze kazdy novy blok udaju je uvozen "User:" a ukoncen "Note:", lze pouzit nize uvednou proceduru (vlozit v editoru VBA do standardniho modulu, v editoru volat F5):
- pro Excel 2007:

Kód: Vybrat vše

Option Explicit

Sub Extrahuj()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, OfsR As Long

  With Worksheets("list1")
    Set SBlk = .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp))
  End With
  Set TCll = Worksheets("list2").Range("a1")
  OfsR = 0
  For Each SCll In SBlk.Cells
    If Left(SCll.Value, 5) = "User:" Then
      TCll.Offset(OfsR, 0).Value = SCll.Offset(0, 1).Value
    End If
    If Left(SCll.Value, 5) = "NOTE:" Then
      TCll.Offset(OfsR, 1).Value = SCll.Offset(0, 2).Value
      OfsR = OfsR + 1
    End If
  Next SCll

  With ActiveWorkbook.Worksheets("List2").Sort
    .SortFields.Add Key:=Range("B1:B" & OfsR), _
        SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
    .SetRange Range("A1:B" & OfsR)
    .Header = xlGuess
    .MatchCase = False
    .Orientation = xlTopToBottom
    .SortMethod = xlPinYin
    .Apply
  End With
End Sub

- pro Excel 2000-3:

Kód: Vybrat vše

Option Explicit

Sub Extrahuj()
  Dim SBlk As Range, SCll As Range
  Dim TCll As Range, OfsR As Long

  With Worksheets("list1")
    Set SBlk = .Range(.Range("A1"), .Cells(.Rows.Count, 1).End(xlUp))
  End With
  Set TCll = Worksheets("list2").Range("a1")
  OfsR = 0
  For Each SCll In SBlk.Cells
    If Left(SCll.Value, 5) = "User:" Then
      TCll.Offset(OfsR, 0).Value = SCll.Offset(0, 1).Value
    End If
    If Left(SCll.Value, 5) = "NOTE:" Then
      TCll.Offset(OfsR, 1).Value = SCll.Offset(0, 2).Value
      OfsR = OfsR + 1
    End If
  Next SCll

    Worksheets("list2").Range("a1:b" & OfsR).Sort Key1:=Range("B1"), Order1:=xlDescending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
End Sub