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