ReSQL.ru
     
powered by simpleCommunicator - 2.0.51     © 2025 Programmizd 02
Мобильная версия    Контакт    Правила    FAQ    Помощь
Доб. в избранное | Игнор. тему | Прикреп. тему | Пометить прочит. / непрочит. | Фильтр
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Html table to array merge cell
7 сообщений из 7, страница 1 из 1
Html table to array merge cell
    #39121842
trexmernii
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
trexmernii
Гость
Добрый день!

Пытаюсь таблицу из html передать в массив без использования копирования на лист Excel. Все осложняется тем, что в таблице есть объединенные ячейки по горизонтали и вертикале. И как раз с этим у меня вопрос. На выходе мне нужен массив в котором вместо объединенных ячеек были бы соответствующие данные относящиеся к объединенным ячейкам.

для понимания простенький пример на картинке.

Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
Sub merge_cells()

Dim oDom As Object: Set oDom = CreateObject("htmlFile")
Dim data As Variant
 
dann = ActiveWorkbook.Worksheets("îñíîâíîé").Cells(1, 1)

oDom.body.innerHTML = dann
Y = 1: x = 1
    
    With oDom.getElementsByTagName("table")(0)

        ReDim data(1 To .Rows.Length + 1, 1 To .Rows(1).Cells.Length + 1)
        t = 0
        a = .Rows.Length - 1
        For a1 = 0 To a
            b = .Rows(a1).Cells.Length - 1
            For b1 = 0 To b
            
                c = .Rows.Item(a1).Cells.Item(b1).colspan
                r = .Rows.Item(a1).Cells.Item(b1).rowspan
                
                    For i1 = 1 To c
                        For i2 = 0 To r - 1
                        n = .Rows.Item(a1).Cells.Item(b1).innerHTML
                        If Len(data(x + i2, Y)) = 0 Then
                        data(x + i2, Y) = n
                        Else
                        Y = Y + 1
                        data(x + i2, Y) = n
                        End If
                        
                        Next
                   Y = Y + 1
                Next
            Next
            Y = 1
            x = x + 1
        Next
    End With

ActiveWorkbook.Worksheets("îñíîâíîé").Cells(4, 1).Resize(UBound(data), UBound(data, 2)).Value = data
  
End Sub
...
Рейтинг: 0 / 0
07.12.2015, 01:39
| Ответить | Цитировать | Написать  
Html table to array merge cell
    #39121876
trexmernii
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
trexmernii
Гость
собственно картинка
...
Рейтинг: 0 / 0
07.12.2015, 08:13
| Ответить | Цитировать | Написать  
Html table to array merge cell
    #39122571
скукотища
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
скукотища
Гость
trexmernii,
 
Data
Код: html
1.
2.
3.
4.
5.
<!-- файл c:\temp\tablecells.htm -->
<table>
<tr><td colspan=2>A</td><td rowspan=2>C</td></tr>
<tr><td>B</td><td> </td></tr>
</table>

 
Code
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
Option Explicit

Sub merge_cells()
    Dim oDom As Object, oTable As Object, oRow As Object, oCell As Object
    Dim iRows As Integer, iCols As Integer
    Dim x As Integer, y As Integer
    Dim xx As Integer, yy As Integer
    Dim colspan As Integer, rowspan As Integer
    Dim real_y As Integer
    Dim txt As String
    Dim data()
    
    Set oDom = GetObject("c:\temp\tablecells.htm", "htmlFile")
    DoEvents
    
    Set oTable = oDom.getElementsByTagName("table")(0)
    DoEvents
    
    'кол-во "строк" в массиве = кол-во строк в таблице
    iRows = oTable.rows.Length
    
    'кол-во "столбцов" в массиве
    For x = 0 To iRows - 1
        Set oRow = oTable.rows(x)
        real_y = 0
        For y = 0 To oRow.Cells.Length - 1
            real_y = real_y + oRow.Cells(y).colspan
        Next y
        If iCols < real_y Then iCols = real_y
    Next x
    
    ReDim data(1 To iRows, 1 To iCols)
    
    For x = 0 To iRows - 1
        Set oRow = oTable.rows(x)
        real_y = 1
        
        For y = 0 To oRow.Cells.Length - 1
            Set oCell = oRow.Cells(y)
            colspan = oCell.colspan - 1
            txt = oCell.innerText
            
            If Len(txt) > 0 Then
                rowspan = oCell.rowspan - 1
                
                For xx = x + 1 To x + 1 + rowspan
                    For yy = real_y To real_y + colspan
                        data(xx, yy) = txt
                    Next yy
                Next xx
            End If
            
            real_y = real_y + colspan + 1
            
        Next y
    Next x
    
    Set oCell = Nothing
    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing
    
    '<DEBUG>
    For x = LBound(data) To UBound(data)
        Debug.Print x & ":[ ";
        For y = LBound(data, 2) To UBound(data, 2)
            Debug.Print y & ":[" & data(x, y) & "] ";
        Next y
        Debug.Print "]"
    Next x
    '</DEBUG>
End Sub


 
Immediate Window
Код: vbnet
1.
2.
1:[ 1:[A] 2:[A] 3:[C] ]
2:[ 1:[B] 2:[] 3:[C] ]

...
Рейтинг: 0 / 0
07.12.2015, 17:22
| Ответить | Цитировать | Написать  
Html table to array merge cell
    #39122572
trexmernii
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
trexmernii
Гость
возможно немного коряво, но зато работает
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
Sub merge_cells()

Dim oDom As Object: Set oDom = CreateObject("htmlFile")
Dim data As Variant
 
dann = ActiveWorkbook.Worksheets("&#238;&#241;&#237;&#238;&#226;&#237;&#238;&#233;").Cells(1, 1)

oDom.body.innerHTML = dann
y = 1: x = 1
    
    With oDom.getElementsByTagName("table")(0)

        ReDim data(1 To .Rows.Length + 1, 1 To .Rows(1).Cells.Length + 1)
        t = 0
        a = .Rows.Length - 1
        For a1 = 0 To a
            b = .Rows(a1).Cells.Length - 1
            For b1 = 0 To b
            
                c = .Rows.Item(a1).Cells.Item(b1).colspan
                r = .Rows.Item(a1).Cells.Item(b1).rowspan
                
                    For i1 = 1 To c
                        For i2 = 0 To r - 1
                            n = .Rows.Item(a1).Cells.Item(b1).innerHTML
                      
                        If y > b Then GoTo sled
                        Do Until Len(data(x + i2, y)) = 0
                        y = y + 1
                        If y > b Then GoTo sled
                        Loop
                        data(x + i2, y) = n
sled:
                        Next
                   y = y + 1
                Next
            Next
            y = 1
            x = x + 1
        Next

    End With

 ActiveWorkbook.Worksheets("&#238;&#241;&#237;&#238;&#226;&#237;&#238;&#233;").Cells(4, 1).Resize(UBound(data), UBound(data, 2)).Value = data
  
End Sub
...
Рейтинг: 0 / 0
07.12.2015, 17:22
| Ответить | Цитировать | Написать  
Html table to array merge cell
    #39122606
trexmernii
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
trexmernii
Гость
скукотища,

В конкретном случае Ваш способ работает, но если распространять на большее то не работает так как нужно.
например:

 
Data
Код: xml
1.
2.
3.
4.
5.
<!-- файл c:\temp\tablecells.htm -->
<table>
<tr><td rowspan=2>A</td><td colspan=2>C</td></tr>
<tr><td>B</td><td> </td></tr>
</table>

 
Immediate Window
Код: xml
1.
2.
1:[ 1:[A] 2:[C] 3:[C] ]
2:[ 1:[B] 2:[] 3:[] ]

...
Рейтинг: 0 / 0
07.12.2015, 17:59
| Ответить | Цитировать | Написать  
Html table to array merge cell
    #39122697
скукотища
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
скукотища
Гость
trexmernii,
попытка #2
 
Data
Код: html
1.
2.
3.
4.
5.
6.
7.
8.
9.
<!-- 
файл c:\temp\tablecells.htm
пустые ячейки для наглядности заполнены '~n'
-->
<table border=1 cellspacing=0 cellpadding=4 width='50%'>
<tr><td rowspan=2>A</td><td colspan=2>C</td><td rowspan=3>E</td><td>~1</td></tr>
<tr><td>B</td><td>~2</td><td rowspan=2>F</td></tr>
<tr><td colspan=3>~3</td></tr>
</table>

 
Code
Код: vbnet
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
25.
26.
27.
28.
29.
30.
31.
32.
33.
34.
35.
36.
37.
38.
39.
40.
41.
42.
43.
44.
45.
46.
47.
48.
49.
50.
51.
52.
53.
54.
55.
56.
57.
58.
59.
60.
61.
62.
63.
64.
65.
66.
67.
68.
69.
70.
71.
72.
73.
74.
75.
76.
77.
78.
Option Explicit

Sub merge_cells()
    Dim oDom As Object, oTable As Object, oRow As Object, oCell As Object
    Dim iRows As Integer, iCols As Integer
    Dim x As Integer, y As Integer
    Dim xx As Integer, yy As Integer
    Dim colspan As Integer, rowspan As Integer
    Dim real_y As Integer
    Dim txt As String
    Dim data()
    Dim idx() As Byte
    
    Set oDom = GetObject("c:\temp\tablecells.htm", "htmlFile")
    DoEvents
    
    Set oTable = oDom.getElementsByTagName("table")(0)
    DoEvents
    
    'кол-во строк в таблице = кол-во "строк" в массиве
    iRows = oTable.rows.Length
    
    'кол-во "столбцов" в массиве
    For x = 0 To iRows - 1
        Set oRow = oTable.rows(x)
        real_y = 0
        For y = 0 To oRow.Cells.Length - 1
            real_y = real_y + oRow.Cells(y).colspan
        Next y
        If iCols < real_y Then iCols = real_y
    Next x
    
    ReDim data(1 To iRows, 1 To iCols)
    ReDim idx(1 To iRows, 1 To iCols)
    
    For x = 0 To iRows - 1
        Set oRow = oTable.rows(x)
        real_y = 1
        
        For y = 0 To oRow.Cells.Length - 1
            Set oCell = oRow.Cells(y)
            colspan = oCell.colspan - 1
            rowspan = oCell.rowspan - 1
            txt = oCell.innerText
            
            While idx(x + 1, real_y) > 0
                real_y = real_y + 1
            Wend
            
            For xx = x + 1 To x + 1 + rowspan
                For yy = real_y To real_y + colspan
                    If Len(txt) > 0 Then
                        data(xx, yy) = txt
                    End If
                    idx(xx, yy) = 1
                Next yy
            Next xx
            
            real_y = real_y + colspan + 1
            
        Next y
    Next x
    
    Set oCell = Nothing
    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing
    
    '<DEBUG>
    For x = LBound(data) To UBound(data)
        Debug.Print x & ":[ ";
        For y = LBound(data, 2) To UBound(data, 2)
            Debug.Print y & ":[" & data(x, y) & "] ";
        Next y
        Debug.Print "]"
    Next x
    '</DEBUG>
End Sub

 
Immediate
Код: vbnet
1.
2.
3.
1:[ 1:[A] 2:[C] 3:[C] 4:[E] 5:[~1] ]
2:[ 1:[A] 2:[B] 3:[~2] 4:[E] 5:[F] ]
3:[ 1:[~3] 2:[~3] 3:[~3] 4:[E] 5:[F] ]

...
Рейтинг: 0 / 0
07.12.2015, 20:12
| Ответить | Цитировать | Написать  
Html table to array merge cell
    #39172748
trexmernii
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
trexmernii
Гость
скукотища,

Спасибо!!! Все работает как надо!
...
Рейтинг: 0 / 0
17.02.2016, 01:16
| Ответить | Цитировать | Написать  
7 сообщений из 7, страница 1 из 1
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Html table to array merge cell
Целевая тема:
Создать новую тему:
Автор:
Закрыть
Цитировать
Найденые пользователи ...
Разблокировать пользователей ...
Читали тему (0):
Читали форум (0):
Пользователи онлайн (0):
Польз. соглашение
NoSQL.ru       Новости, Чат       Фотоальбом: Участники, Встречи
Закрыть
start [/forum/topic.php?fid=60&msg=39122697&tid=2155624]:
 0ms
get settings:
 8ms
get forum list:
 15ms
check forum access:
 4ms
check topic access:
 4ms
track hit:
 90ms
get topic data:
 11ms
get forum data:
 3ms
get page messages:
 38ms
get tp. blocked users:
 1ms
others: 319ms
total:  493ms
созд. / загр.: 493ms
x
x
Закрыть


Просмотр
0 / 0
Close
Debug Console [Select Text]