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.
Děkuji
Makro - Excel
-
- Level 4
- Příspěvky: 1142
- Registrován: srpen 08
- Pohlaví:
- Stav:
Offline
Re: Makro - Excel
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:
- pro Excel 2000-3:
- 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
-
- Mohlo by vás zajímat
- Odpovědi
- Zobrazení
- Poslední příspěvek
-
- 9
- 1281
-
od mmmartin
Zobrazit poslední příspěvek
29 srp 2023 16:47
-
- 16
- 6906
-
od mirekol
Zobrazit poslední příspěvek
20 říj 2023 08:31
-
- 1
- 730
-
od Grimm
Zobrazit poslední příspěvek
12 bře 2024 21:43
-
- 2
- 2048
-
od honzzicek
Zobrazit poslední příspěvek
01 črc 2023 08:57
-
- 3
- 2321
-
od Story-Long
Zobrazit poslední příspěvek
14 srp 2023 10:11
Kdo je online
Uživatelé prohlížející si toto fórum: Žádní registrovaní uživatelé a 3 hosti