Option Explicit '********************************************************************* ' HTML2Excel/Directory2Excel Ver 2.0 ' ' HTML の TABLE を Excel のワークシートに読み込みます ' HTML2Excel は HTML文書に含まれる TABLE の内容を読み込みます ' Directory2Excel はディレクトリ中の全 HTML文書を対象にします ' 'Designed for HPCF http://www.hpcf.com/ 'by poetlabo http://www.bekkoame.ne.jp/%7Epoetlabo/ 'also available at http://www.vector.co.jp/authors/VA014833/ 'Copyleft:1999, 魔術幻燈 poetlabo@cap.bekkoame.ne.jp '作者の許可なく改変・盗用・配布することを歓迎します '********************************************************************* Sub HTML2Excel2() Dim file_name As String file_name = Application.GetOpenFilename("HTML文書 (*.htm),*.htm") If file_name = "False" Then Exit Sub Call GetTABLE(file_name) Application.StatusBar = "HTMLタグを削除しています。" Call ReplaceTags("<*>", "") '// HTMLタグ削除 Call ReplaceTags(" ", "") '// 空白文字削除 Call ReplaceTags("&", "&") '// &記号 Call ReplaceTags("<", "<") '// 小なり Call ReplaceTags(">", ">") '// 大なり Call ReplaceTags(Chr(9), "") '// タブ文字削除 Application.StatusBar = False Beep MsgBox file_name & "の内容を読み込みました。", 0, "HTML2Excel" End Sub Sub GetTABLE(file_name As String) Const TABLEstag As String = " 0 cn = cn + 1 ReDim Preserve StrArray(1 To cn) StrArray(cn) = Mid(TextLine, Cstart, Cend - Cstart) Cstart = InStr(Cend, TextLine, tagc, 1) + 1 Cend = GetTHTDstart(Cstart, TextLine) Loop cn = cn + 1 ReDim Preserve StrArray(1 To cn) StrArray(cn) = Mid(TextLine, Cstart, Len(TextLine) - Cstart + 1) Range(Cells(rn, 1), Cells(rn, cn)).Value = StrArray() End Sub Function GetTHTDstart(Cstart As Integer, TextLine As String) As Integer Const THstag As String = "