< návrat zpět

MS Excel


Téma: Prohledání textu v buňkách rss

Zaslal/a 9.5.2016 14:53

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í.

Příloha: zip31463_slova.zip (8kB, staženo 27x)
Jméno
Kontrola
Text
  b i u s img code url hr   1 2 3 4 5 6 7 8 9 10

#031465
avatar
Mně to zadání jasné není, takže obecně - filtr, SUBTOTAL, COUNTIF, kontingenčka, ...citovat
#031466
avatar
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
#031467
avatar
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
#031471
Jeza.m
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
#031472
avatar
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 7

to xlnc
Co vám v zadání chybí?citovat
#031474
Jeza.m
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
#031475
avatar
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: gif31475_nahled.gif (62kB, staženo 28x)
31475_nahled.gif
citovat
#031476
avatar
Bože, tenhle debilní server mě ničí.
Příloha: gif31476_nahled.gif (62kB, staženo 27x)
31476_nahled.gif
citovat
#031480
avatar
Díky oběma, prověřuji, zkouším... určitě se ozvu :-)citovat

Uživatelské menu

Nejste přihlášen(a)
avatar\n

Menu

Formulář Faktura

Formulář Faktura IV

Oblíbený formulář Faktura byl vylepšen a rozšířen.
Více se dočtete zde.

Helios iNuvio

Používáte podnikový systém Helios iNuvio? Potřebujete pomoci se správou nebo vyvinout SQL proceduru? Více informací naleznete na stránce Helios iNuvio.

On-line nástroje