MS Excel

Dobrý den
žádám o radu s nasledujícím:
V listu TEMP mám ve sloupci A několik tisíc řádků textu(v příkladu méně, ne není to xml - bohužel). Potřebuji je prohledat a vypsat do listu "05" některé položky - viz příklad.
Formáty a počty výskytu jsou popsány.
Díky za jakýkoliv nápad, řešení.

Zaslat odpověď >

xlnc(9.5.2016 15:06)#031465

Mně to zadání jasné není, takže obecně - filtr, SUBTOTAL, COUNTIF, kontingenčka, ...citovat

GeorgeK(9.5.2016 15:30)#031466

např. list TEMP, řádek 3 = <vec>Seladon November</vec>
potřebuji vyselektovat Seladon November a uložit do listu "05" do C2 (podle nadpisů sloupců).
To vše řešit makrem.citovat

xlnc(9.5.2016 17:36)#031467

Takže potřebujete separovat text z tagů nebo ...? Na to se hodí regulární výrazy. Ale pořád mi to zadání přijde nekompletní.citovat

Jeza.m(10.5.2016 9:50)#031471

Jen takový neuniverzální pokus
Public Sub ROZDELIT()
Dim rd As Single
rd = 2

For i = 1 To List1.UsedRange.Rows.Count
If List1.Cells(i, 1) = "<info>" Then
List2.Cells(rd, 4) = Replace(Replace(List1.Cells(i + 3, 1), " <datum_platnosti>", ""), "</datum_platnosti>", "")
List2.Cells(rd, 2) = Replace(Replace(List1.Cells(i + 1, 1), " <cj>", ""), "</cj>", "")
List2.Cells(rd, 3) = Replace(Replace(List1.Cells(i + 2, 1), " <vec>", ""), "</vec>", "")
Do While List1.Cells(i, 1) <> "</info>"
If List1.Cells(i, 1) = " <pozadavek>" Then
List2.Cells(rd, 7) = CStr(Replace(Replace(List1.Cells(i + 2, 1), " <dr>", ""), "</dr>", ""))
List2.Cells(rd, 5) = "'" & CStr(Replace(Replace(List1.Cells(i + 3, 1), " <priorita>", ""), "</priorita>", ""))
List2.Cells(rd, 6) = "'" & CStr(Replace(Replace(List1.Cells(i + 4, 1), " <priorita2>", ""), "</priorita2>", ""))
rd = rd + 1
End If
i = i + 1
Loop
End If
Next

End Sub
za předpokladu že struktura je vždy stejná.
M@citovat

GeorgeK(10.5.2016 12:17)#031472

to Jeza.m
Díky za reakci... Funguje... Ale pouze na vzorku, zapomněl jsem říct, že to co potřebuji "extrahovat" NENÍ v listu TEMP vždy na stejném řádku

to xlnc
Co vám v zadání chybí?citovat

Jeza.m(10.5.2016 15:04)#031474

Tak ještě jeden pokus...
Public Sub rozdel()
Dim cj, vec As String
Dim dt As Date
Dim pozadavky() As String
Dim pozadavek As String
Dim tmppocet As Single
Dim rd As Single
Dim tmpxml, tmpxmlpoz As String
Dim tmpp() As String

rd = 2

For i = 1 To List1.UsedRange.Rows.Count
If List1.Cells(i, 1) = "<info>" Then
tmpxml = ""
tmppocet = 0
Erase pozadavky
Do While List1.Cells(i, 1) <> "</info>"
tmpxml = tmpxml & vbNewLine & List1.Cells(i, 1)

If UCase(Replace(List1.Cells(i, 1), " ", "")) = UCase("<pozadavek>") Then tmpxmlpoz = ""
tmpxmlpoz = tmpxmlpoz & vbNewLine & List1.Cells(i, 1)
If UCase(Replace(List1.Cells(i, 1), " ", "")) = UCase("</pozadavek>") Then
pozadavek = gettag(tmpxmlpoz, "dr")
If pozadavek <> "" Then
tmppocet = tmppocet + 1
ReDim Preserve pozadavky(tmppocet - 1)
pozadavky(tmppocet - 1) = pozadavek & "|" & gettag(tmpxmlpoz, "priorita") & "|" & gettag(tmpxmlpoz, "priorita2")
End If
End If

i = i + 1
Loop

For Each p In pozadavky
List2.Cells(rd, 2) = "'" & gettag(tmpxml, "cj")
List2.Cells(rd, 3) = "'" & gettag(tmpxml, "vec")
List2.Cells(rd, 4) = CDate(gettag(tmpxml, "datum_platnosti"))
List2.Cells(rd, 1) = CDate(List2.Cells(rd, 4))

tmpp = Split(p, "|")
List2.Cells(rd, 7) = "'" & tmpp(0)
List2.Cells(rd, 5) = "'" & tmpp(1)
List2.Cells(rd, 6) = "'" & tmpp(2)
rd = rd + 1
Next

End If
Next
End Sub

Public Function gettag(text, tag)
Dim start, konec As Single
For i = 1 To Len(text)
If UCase(Right(Left(text, i), Len(tag) + 2)) = UCase("<" & tag & ">") Then start = i + 1
If UCase(Right(Left(text, i), Len(tag) + 3)) = UCase("</" & tag & ">") Then
konec = i - (Len(tag) + 2)
Exit For
End If
Next
gettag = Mid(text, start, konec - start)
End Function
M@citovat

xlnc(10.5.2016 15:23)#031475

K zamyšlení.. obrázek přílohy ukazuje, jak to dopadne po dvojím užití Data / Text do sloupců a možnost se vykašlat na nějaké parsování obsahu tagů.

Příloha: gif