Гость
Войти | Профиль | Очистить
Действия ...
Форумы / Visual Basic [игнор отключен] [закрыт для гостей] / Html table to array merge cell / 7 сообщений из 7, страница 1 из 1
07.12.2015, 01:39
    #39121842
trexmernii
trexmernii
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Html table to array merge cell
Добрый день!

Пытаюсь таблицу из 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, 08:13
    #39121876
trexmernii
trexmernii
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Html table to array merge cell
собственно картинка
...
Рейтинг: 0 / 0
| Ответить | Цитировать | Написать  
07.12.2015, 17:22
    #39122571
скукотища
скукотища
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Html table to array merge cell
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
    #39122572
trexmernii
trexmernii
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Html table to array merge cell
возможно немного коряво, но зато работает
Код: 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:59
    #39122606
trexmernii
trexmernii
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Html table to array merge cell
скукотища,

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

 
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, 20:12
    #39122697
скукотища
скукотища
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Html table to array merge cell
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
| Ответить | Цитировать | Написать  
17.02.2016, 01:16
    #39172748
trexmernii
trexmernii
Гость
Скрыть профиль Поместить в игнор-лист Сообщения автора в теме
Html table to array merge cell
скукотища,

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


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