Доброго времени суток. Есть макрос который делает из выделенной таблицы в эксель таблицу в формале HTML. Код работает прекрасно, но если таблица содержит большое количество строк (около 1500), то текст копируется в буфер обмена, но не вставляется в файл. Код прилагаю.
Код
Private Sub CommandButton1_Click()
' макрос для экспорта выделенного диапазона ячеек в HTML
On Error Resume Next
Selection.Areas(1).Select ' на случай выделения несвязанных диапазонов
iFirstLine = Selection.Row
iFirstCol = Selection.Column
iLastLine = iFirstLine + Selection.Rows.Count - 1
iLastCol = iFirstCol + Selection.Columns.Count - 1
'HTML классы для таблицы и четного ряда данных
sTableClass = "ExcelTable"
sOddRowClass = "odd"
sOutput = "<div><table class='" & sTableClass & "' border=1 width=100% align=center>" ' Начинаем таблицу
'sOutput = sOutput & "<caption>" & Cells(iFirstLine, iFirstCol).Text & "</caption>"
For k = iFirstLine To iLastLine ' Обрабатываем Excel таблицу
If (k \ 2 <> k / 2) Then 'проверяем на четность
sLine = "<tr class ='" & sOddRowClass & "'>"
Else
sLine = "<tr>"
End If
iCountColspan = 0 'счетчик объединенных ячеек
For j = iFirstCol To iLastCol
'Проверяем, не объединена ли эта ячейка с соседними.
If Cells(k, j).MergeCells = True Then
'Получаем число объединенных ячеек
iCountColspan = Cells(k, j).MergeArea.Count
Else
iCountColspan = 0
End If
Set oCurrentCell = ActiveSheet.Cells(k, j)
sLine = sLine & "<td"
'Проверяем, нужно ли вставлять код объединения ячейки с соседними
If iCountColspan > 1 Then
sLine = sLine & " colspan=" & iCountColspan
j = j + iCountColspan - 1 'пропускаем ячейки
iCountColspan = 0
End If
'Если по центру
If oCurrentCell.HorizontalAlignment = -4108 Then sLine = sLine & " style='text-align: center;'"
sLine = sLine & ">"
'Если пусто, прописываем
If oCurrentCell.Text <> "" Then sValue = oCurrentCell.Text Else sValue = " "
'Если жирный
If oCurrentCell.Font.Bold = True Then sValue = "<b>" & sValue & "</b>"
'Если курсив
If oCurrentCell.Font.Italic = True Then sValue = "<i>" & sValue & "</i>"
sLine = sLine & sValue & "</td>"
If k = iFirstLine Then sLine = Replace(sLine, "<td", "<th")
Next j
sOutput = sOutput & sLine & "</tr>"
Next k
'Заканчиваем таблицу
sOutput = sOutput & "</table></div> <style>& ""table{width: 100%; border-collapse: collapse;}td{border: 1px solid;border-collapse:collapse;}</style>"
' Копируем полученный HTML в буфер обмена
With GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
.SetText sOutput: .PutInClipboard
End With
'записываем результат в файл .txt
clipboard = CreateObject("HTMLFile").parentWindow.clipboardData.GetData("text")
'удаляем прошлую версию файла
Kill "G:Лист1.html"
file = "G:\Лист1.txt"
'8 - дозапись, True - создавать, если
Set ofile = CreateObject("Scripting.FileSystemObject").OpenTextFile(file, 8, True)
'Вписываем из буфера обмена
ofile.WriteLine (clipboard)
ofile.Close
WScript.Echo "OK"
'Из файла .txt делаем .html
Name "G:\Лист1.txt" As "G:\Лист1.html"
Если убрать пункт "On Error Resume Next" ошибка будет выдаваться на строке "ofile.WriteLine (clipboard)" После ошибки результат остается в буфере обмена и я могу вручную вставить его в файл, но хотелось бы сделать это в автоматическом режиме.
Есть ли другие способы вставлять текст в текстовый файл из буфера обмена? Или способ исправления ошибки?
Behruz, к сожалению опять выводит пустой файл. Я бы с удовольствием поделился файлом, но там много коммерческих моментов. В таблице есть ячейки с максимальным количеством символов в ней. Возможно проблема в этом? Позже попробую отправить файл с большой таблицей.
RAN, поправка резонная. Попробовал - результат такой же :(Увидел что в некоторых строках есть непечатные символы и вещи по типу “–”. Попробую их убрать и вернусь с результатом
Sub Макрос1()
With ActiveWorkbook.PublishObjects.Add(xlSourceRange, _
"C:\146547 Sl.htm", "Sheet1", "$C$5:$L$28", _
xlHtmlStatic, "146547 Sl_14854", "")
.Publish (True)
.AutoRepublish = False
End With
End Sub
Спасибо, такой вариант кода работает. Он подошел бы, но он сохраняет пропорции и съедает текст, а нужен весь текст из ячейки некоторые из которых содержат по несколько тысяч символов.
А также в файл файл закидывается много мусора, что мне не нужно. Идеальный результатом бы был файл как в коде который был изначально. При удалении некоторых символов по типу "\" и "/" стало работать с некоторыми таблицами. Пытался также убрать непечатные символы, но не помогло. Некоторые таблицы все также выдаются пустыми. Пробовал с бОльшими таблицами, но из другого файла и все работает. Проблема видимо не в недостатке памяти в буфере обмена и не в недостатке линии в текстовом файле, а в недопустимых символах в ячейках. Буду думать...
Всем спасибо, проблему решил. Изменил метод записи и все заработало с любыми таблицами и символами.
Код
Private Sub TableHtml()
' макрос для экспорта выделенного диапазона ячеек в HTML
On Error Resume Next
' 'Прячем ненужные ячейки если необходимо
' Range("G:H").EntireColumn.Hidden = True
'На случай выделения несвязанных диапазонов
Selection.Areas(1).Select
'Обозначаем строки и колонки
iFirstLine = Selection.Row
iFirstCol = Selection.Column
iLastLine = iFirstLine + Selection.Rows.Count - 1
iLastCol = iFirstCol + Selection.Columns.Count - 1
'HTML классы для таблицы и четного ряда данных
sTableClass = "ExcelTable"
sOddRowClass = "odd"
sOutput = "<div><table class='" & sTableClass & "' border=1 width=100% align=center>" ' Начинаем таблицу
'sOutput = sOutput & "<caption>" & Cells(iFirstLine, iFirstCol).Text & "</caption>"
For k = iFirstLine To iLastLine ' Обрабатываем Excel таблицу
If (k \ 2 <> k / 2) Then 'проверяем на четность
sLine = "<tr class ='" & sOddRowClass & "'>"
Else
sLine = "<tr>"
End If
iCountColspan = 0 'счетчик объединенных ячеек
For j = iFirstCol To iLastCol
'Проверяем, не объединена ли эта ячейка с соседними.
If Cells(k, j).MergeCells = True Then
'Получаем число объединенных ячеек
iCountColspan = Cells(k, j).MergeArea.Count
Else
iCountColspan = 0
End If
Set oCurrentCell = ActiveSheet.Cells(k, j)
sLine = sLine & "<td"
'Проверяем, нужно ли вставлять код объединения ячейки с соседними
If iCountColspan > 1 Then
sLine = sLine & " colspan=" & iCountColspan
j = j + iCountColspan - 1 'пропускаем ячейки
iCountColspan = 0
End If
'Если по центру
If oCurrentCell.HorizontalAlignment = -4108 Then sLine = sLine & " style='text-align: center;'"
sLine = sLine & ">"
'Если пусто, прописываем
If oCurrentCell.Text <> "" Then sValue = oCurrentCell.Text Else sValue = " "
'Если жирный
If oCurrentCell.Font.Bold = True Then sValue = "<b>" & sValue & "</b>"
'Если курсив
If oCurrentCell.Font.Italic = True Then sValue = "<i>" & sValue & "</i>"
sLine = sLine & sValue & "</td>"
If k = iFirstLine Then sLine = Replace(sLine, "<td", "<th")
Next j
sOutput = sOutput & sLine & "</tr>"
Next k
sOutput = sOutput & "</table></div> <style>& ""table{width: 100%; border-collapse: collapse;}td{border: 1px solid;border-collapse:collapse;}</style>" 'Заканчиваем таблицу
'Удаляем прошлую версию файла
Kill "G:\Лист1.html"
'записываем результат в файл .txt
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Dim Fileout As Object
Set Fileout = fso.CreateTextFile("G:\Лист1.txt", True, True)
Fileout.Write (sOutput)
Fileout.Close
'Из файла .txt делаем .html
Name "G:\Лист1.txt" As "G:\Лист1.html"
'Открываем хтмльку, если необходимо
CreateObject("wscript.shell").Run "explorer.exe /e,/open,""" & "G:\Лист1.html"
End Sub