dotNETportal.cz

Jak vyberu z Word tabulky všechny řádky obsahující slovo "Podmínka"??? Děkuji.

Nevím, zda se potřebuje dostat do stavu, kdy jsou vybrány řádky obsahující slovo "Podmíka" všechny najednou - nevím, co sledujete. Vybrat je postupně v cyklu a provádět s nimi nějaké operace je v následující ukázce. Konkrétně bude obarveno pozadí všech řádků první tabulky aktivního dokumentu Wordu na světle žluto. Po odklepnutí oznámení o konci ukázky se pozadí buněk nastaví na automatické.

 Sub HledejOznac()
    Dim konec As Boolean
    Dim hledane As String
    hledane = "*Podmínka*"
    Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Name:=""
    Do
      If Selection.Information(wdWithInTable) = True Then
        Selection.SelectRow
          If Selection.Range.Text Like hledane Then
          Selection.Cells.Shading.BackgroundPatternColor = wdColorLightYellow
          Selection.MoveDown Unit:=wdLine, Count:=1
        Else
          Selection.Cells.Shading.BackgroundPatternColor = wdColorAutomatic
          Selection.MoveDown Unit:=wdLine, Count:=1
       End If
     Else
       konec = True
     End If
    Loop While Not konec
    MsgBox "Ukázka skončena"
    Selection.Tables(1).Select
    Selection.Shading.Texture = wdTextureNone
    Selection.Shading.BackgroundPatternColor = wdColorAutomatic
    Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Name:=""
  End Sub
 

Konec makra je třeba změnit:

    MsgBox "Ukázka skončena"
    Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Name:=""
    Selection.Tables(1).Select
    Selection.Shading.Texture = wdTextureNone
    Selection.Shading.BackgroundPatternColor = wdColorAutomatic
    Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Name:=""

Dobrý den, děkuji moc, ano, potřebuji vybrat všechny najednou a pak z těchto vybraných řádků vytvořit novou tabulku, kde bude ale jen pouze sloupec s číslem řádku a sloupec obsahující hledaná slovy, v tomto případě podmínka!!! Přesto moc děkuji, začínám, je to pro mě od vás moc cenné, mám se čeho chytit a uložím si samozřejmě jako šablonu :)... Hezký zbytek dne...

I když jsem již pár fungujích volovinek ve VBA spráskal, tak znalec nejsem. Navíc vše jsem psal v Excelu a pouze cestou záznamu makra a pak již jen metodou pokus / omyl. Přesto si dovolím tvrdit, že právě postupné čtení tabulky a nejspíš po buňkách a zpracování zjištěných dat bude cesta k cíli, který sledujete. Neumím si totiž představit co dál, bude-li vybráno více řádků tabulky najednou. Ale vím málo o struktuře a uspořádání textu "podmínek" ve zdrojové tabulce, abych mohl něco tvrdit. Tak jenom jako tip.

Pokud máte zájem, pošlu Vám finální řešení, které jsme dali dohromady společně s kolegou, který je mnohem zkušenější. Je to poměrně rozsáhlé. Když mi dáte mail, poslal bych Vám šsblonu... já také začíám :)... Jirka...

Sub sestav_vysledne_tabulky()

    Dim hodnot(100, 3)
    i = 1

    ' Nalezeni tabulky ve zprave  ********************************************************************
    Selection.HomeKey Unit:=wdStory
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "Poř.^pčís."           ' Hledany text
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute
    Selection.HomeKey Unit:=wdLine


    index_tab = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count
    poc_rad = ActiveDocument.Tables(index_tab).Rows.Count
    For k = 2 To poc_rad
        hodnoceni = ""
        On Error Resume Next
        hodnoceni = odstran_spatne_znaky(ActiveDocument.Tables(index_tab).Cell(k, 5).Range.Text)
        On Error GoTo 0
        If hodnoceni <> "" Then
            If hodnoceni = "2" Or hodnoceni = "3" Then
                hodnot(i, 1) = odstran_spatne_znaky(ActiveDocument.Tables(index_tab).Cell(k, 1).Range.Text)
                temp = odstran_spatne_znaky(ActiveDocument.Tables(index_tab).Cell(k, 4).Range.Text)
                hodnot(i, 2) = dalsi_uprava_formatu(temp)
                hodnot(i, 3) = hodnoceni
                i = i + 1
            End If
        End If
    Next k
    'For k = 1 To i - 1: MsgBox hodnot(k, 3) & " ... " & hodnot(k, 1) & " ... " & hodnot(k, 2): Next k
    
    ' odstraneni vsech radku v tabulce neshod - az na 1. a 2. radek
    For t = 1 To 2
        With ActiveDocument.Tables(index_tab + t)
            NumRows = .Rows.Count
            For m = NumRows To 3 Step -1: .Rows(m).Delete: Next m
            If NumRows >= 2 Then
                .Cell(2, 1).Range.Text = "": .Cell(2, 2).Range.Text = ""
            Else
                ActiveDocument.Tables(index_tab + t).Rows.Add
                .Cell(2, 1).Shading.BackgroundPatternColor = wdColorAutomatic
                .Cell(2, 2).Shading.BackgroundPatternColor = wdColorAutomatic
                .Cell(2, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
            End If
        End With
    Next t

    ' zlute neshody
    rad_vypis = 2
    With ActiveDocument.Tables(index_tab + 1)
        For q = 1 To i - 1
            If hodnot(q, 3) = 2 Then
                If rad_vypis > 2 Then .Rows.Add
                .Cell(rad_vypis, 1).Range.Text = hodnot(q, 1): .Cell(rad_vypis, 2).Range.Text = hodnot(q, 2)
                rad_vypis = rad_vypis + 1
            End If
        Next q
    End With
    ' cervene neshody
    rad_vypis = 2
    With ActiveDocument.Tables(index_tab + 2)
        For q = 1 To i - 1
            If hodnot(q, 3) = 3 Then
                If rad_vypis > 2 Then .Rows.Add
                .Cell(rad_vypis, 1).Range.Text = hodnot(q, 1): .Cell(rad_vypis, 2).Range.Text = hodnot(q, 2)
                rad_vypis = rad_vypis + 1
            End If
        Next q
    End With
    
    skoc_na_tab_neshod          ' PONECHAT ??????????????????????????????????????????????????????????????????????
    
End Sub

Toto je vysledne reseni, ja to jsem i schopen dat dohromady, jenze me vzdy silene tlaci cas!!! U nas musi byt vse hned, no... Takze sned take konecne necim prispeji ja...

Děkuji za nabídku a omluvte, že se nechci zabývat celou úlohou, snažil jsem se jen pomoct s dílčím problémem. Uvedený kód proto nebudu komentovat