'********************************************************************* ' HTML2Excel/Directory2Excel Ver 1.02 ' ' 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 Directory2Excel() Dim dir_name As String, file_name As String Dim rn As Integer dir_name = Application.GetOpenFilename( _ "HTMLファイル (*.htm),*.htm", 1, _ "HTMLファイルをどれか一つ選んでください" _ ) If dir_name = "False" Then Exit Sub file_name = Dir("*.htm", vbNormal) Do Until file_name = "" Call ImportHTML(file_name, rn) rn = rn + 1 file_name = Dir() Loop Application.StatusBar = "HTMLタグを削除しています。" Call ReplaceTags("<*>", "") '// HTMLタグ削除 Call ReplaceTags(" ", "") '// 空白文字削除 Call ReplaceTags("&", "&") '// &記号 Call ReplaceTags("<", "<") '// 小なり Call ReplaceTags(">", ">") '// 大なり Call ReplaceTags(Chr(9), "") '// タブ文字削除 Application.StatusBar = False Beep MsgBox dir_name & "が入っているディレクトリの内容を読み込みました。", 0, "Directory2Excel" End Sub Sub HTML2Excel() Dim file_name As String Dim rn As Integer file_name = Application.GetOpenFilename("HTML文書 (*.htm),*.htm") If file_name = "False" Then Exit Sub rn = 0 'rn = ActiveSheet.UsedRange.Rows.Count Call ImportHTML(file_name, rn) 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 ImportHTML(file_name As String, rn As Integer) Dim FileNum As Integer Dim TRn As String, TextLine As String Dim TRs As Long Application.StatusBar = "HTMLファイルを開いています。" FileNum = FreeFile() Open file_name For Input Access Read As #FileNum On Error GoTo CloseFile Do Until EOF(FileNum) Line Input #FileNum, TextLine TRn = TRn & TextLine Loop TRs = InStr(1, TRn, "