Option Explicit Dim intNumArticle As Integer '記事数は全プログラム共通の変数。 Sub TangoList() ' 理系英語ブログから英単語リスト作成 DeleteSheets ' いらないシートを消す MakeNumTitleHtml '記事番号のhtmlリストを作る Call Seiretsu("z記事番号") 'htmlリストを記事番号順に整列 GetLineKiji '各記事が始まる行番号と終わる行番号を書く。 Call Seiretsu("z記事の分解") '記事の場所リストを記事番号順に整列 ModifyFirst ' 最初の記事（記事番号最大）のみの処理。 CutKiji '記事を別々のファイルに分解する。 GetTango 'zb記事番号のファイルに単語部分を出力する。目で確認してから次へ進む。 MergeTango '単語の記事別ファイルを１つにする。 SeikeiTango '単語の整形をする。今の所、単語の冒頭の・を取る。 ' 入力ファイルの状態によっては、条件を増やす。 KeizokuLine ' 継続行を１行にまとめる。 BunriImi '単語と意味の分離 　６重ループはデバックのため残してある。 GetSort ' 単語のソート SameWord '同じ単語の処理 Addhtml '記事番号の横の列にhtmlを入れておく。 CombineBangou ' 同じ単語で違う記事番号を結合する。 OutputList ' 最終出力　　　★　１セルが256文字以上になるので注意。 End Sub Sub OutputList() '最終出力　いらない継続行は消す。 Dim wsInput As Worksheet, wsNew As Worksheet Dim intRows As Integer, intList1 As Integer, intList2 As Integer Dim str1 As String, str2 As String, str3 As String Dim intLen1 As Integer, strAll As String, strAll2 As String Set wsInput = Worksheets("z同じ単語") Set wsNew = Worksheets.Add() ' 新しいワークシート wsNew.Name = "z単語リスト" 'シート名の前にzを付けて、後で消しやすくする。 wsInput.Range("A:IV").Copy 'wsInput.Copy before:=wsInput　はだめ。★ '256文字以上のセルはコピーできない｡ 'http://support.microsoft.com/kb/213548/ja wsNew.Range("A1").Select wsNew.Paste intRows = wsInput.Range("b65536").End(xlUp).Row '入力データが終わる行 For intList1 = 1 To intRows - 1 ' 後ろから消す intList2 = intRows - intList1 + 1 If Range("a" & intList2).Value = "continue" Then Rows(intList2).Delete '継続行はもういらない。 End If Next intRows = wsInput.Range("b65536").End(xlUp).Row '行数が減っている。 For intList1 = 1 To intRows str1 = Range("b" & intList1).Value str2 = Range("d" & intList1).Value str3 = Range("e" & intList1).Value Range("a" & intList1) = str1 & " " & str2 & " " & str3 Next End Sub Sub CombineBangou() ' 同じ単語の記事番号を１行にまとめる。 ' 同じ単語の個数も数えておく。 Dim wsNow As Worksheet Dim intRows As Integer, intLine1 As Integer Dim str1 As String, str2 As String Dim intCont As Integer Set wsNow = Worksheets("z同じ単語") intRows = wsNow.Range("b65536").End(xlUp).Row ' 現在のデータの行数 For intLine1 = intRows To 2 Step -1 If Range("a" & intLine1).Value = "continue" Then str1 = Range("d" & intLine1).Value str2 = Range("d" & intLine1 - 1).Value Range("d" & intLine1 - 1).Value = str2 & ", " & str1 End If Next End Sub Sub Addhtml() '記事番号のURLが入ったファイルから取ってくる。 Dim wsKiji As Worksheet, wsNow As Worksheet Dim intRows As Integer, intLine As Integer, intNum As Integer Dim strhtml As String Set wsKiji = Worksheets("z記事番号") Set wsNow = Worksheets("z同じ単語") Set wsNow = ActiveSheet intRows = wsNow.Range("b65536").End(xlUp).Row ' 現在のデータの行数 Range("d:d").Insert For intLine = 1 To intRows intNum = Range("c" & intLine).Value strhtml = wsKiji.Range("b" & intNum).Value 'htmlのリンク付記事番号を持ってくる。 Range("d" & intLine).Value = strhtml Next End Sub Sub SameWord() ' 同じ単語が２度以上出る場合は、マーキングする。 Dim wsInput As Worksheet, wsNew As Worksheet Dim intRows As Integer, intLine As Integer Dim str1 As String, str2 As String Set wsInput = Worksheets("zソート") wsInput.Copy before:=wsInput Set wsNew = ActiveSheet wsNew.Name = "z同じ単語" intRows = wsInput.Range("b65536").End(xlUp).Row '入力データが終わる行 For intLine = 2 To intRows str2 = Trim(Range("b" & intLine - 1).Value) '前の行の単語を入れる str1 = Trim(Range("b" & intLine).Value) If str1 = str2 Then Range("a" & intLine).Value = "continue" End If Next End Sub Sub GetSort() '単語をアルファベット順にソートする。 Dim wsInput As Worksheet, wsNew As Worksheet Dim intRows As Integer, intLine As Integer Set wsInput = Worksheets("z単語意味分離") Set wsNew = Worksheets.Add() ' 新しいワークシートを作る。 wsNew.Name = "zソート" '後で消しやすいように頭にzを付ける。" Set wsNew = ActiveSheet intRows = wsInput.Range("A65536").End(xlUp).Row '入力データが終わる行 For intLine = 1 To intRows Range("b" & intLine).Value = wsInput.Range("c" & intLine).Value '単語 Range("c" & intLine).Value = wsInput.Range("a" & intLine).Value 'URL Range("d" & intLine).Value = wsInput.Range("d" & intLine).Value '意味 Next With wsNew .Range("B1").Sort key1:=.Range("B1"), order1:=xlAscending, _ key2:=.Range("c1"), order1:=xlAscending, _ key3:=.Range("d1"), order1:=xlAscending, header:=xlNo 'ソートの第１キー：単語のアルファベット順。第２キー：記事番号 ' Rangeの前にピリオドを入れること。 End With End Sub Sub BunriImi() ' 単語の行から空白を探して単語と意味に分割する。 Dim wsInput As Worksheet, wsNew As Worksheet Dim intRows As Integer, intLine As Integer, intWord As Integer Dim intPos1 As Integer Dim str1 As String, strWord1 As String, strWord2 As String Dim strWordShort1 As String, strWordRest1 As String, strStatus1 As String Dim strWordRest2 As String Dim strWordAll As String, strWordRest As String, strStatus As String Dim intTime As Integer Set wsInput = Worksheets("z単語全部整形") wsInput.Copy before:=wsInput Set wsNew = ActiveSheet wsNew.Name = "z単語意味分離" intRows = Range("A65536").End(xlUp).Row '入力データが終わる行 For intLine = 1 To intRows '単語１個１行 Range("a" & intLine).Interior.ColorIndex = 2 ' 白に戻しておく。 str1 = Trim(wsInput.Range("c" & intLine).Value) Call GetBlank(intPos1, str1) ' 最初の半角または全角の空白の場所を探す intWord = 1 '単語数。連語の場合は２以上 strWord2 = "" If intPos1 > 1 Then strWord1 = Left(str1, intPos1 - 1) strWord2 = Trim(Mid(str1, intPos1 + 1)) ' 最初の空白の右側 If InStr(strWord2, "の略") > 0 Then '特殊な場合 strStatus1 = "end" Else '普通はこちら。後半の最初は単語か。 Call GetString(strWord2, strWordShort1, strWordRest1, strStatus1, _ intLine, 2) End If strWordAll = strWord1 '少なくとも最初の単語は入る If strStatus1 = "end" Then 'おしまい strWordRest = strWord2 ' 意味部分も確定 Else '単語は２個以上 intTime = 1 '連語中の単語数　初期化 Do While strStatus1 = "continue" And intTime <= 5 ' ５個までは調べる strWordAll = strWordAll & " " & strWordShort1 strWordRest = strWordRest1 '今回で終わる場合はこれが出力になる。 Call GetString(strWordRest1, strWordShort1, strWordRest2, _ strStatus1, intLine, intTime) strWordRest1 = strWordRest2 '次回の入力 intTime = intTime + 1 Loop End If Range("c" & intLine).Value = strWordAll Range("d" & intLine).Value = strWordRest End If Next '次の単語 Columns("C").EntireColumn.AutoFit '　C列だけ幅を広げる End Sub Sub GetString(ByVal strInput As String, strShort As String, _ strRest As String, strStatus As String, ByVal intLine As Integer, _ intTime As Integer) '　入力文字列を空白（半角または全角）で切れたら切って戻す。 ' strInput -> strShort + strRest ' strStatus = "continue" 切れた, "end" 切れず。 ' 但し、strShortは１字めが英字。他の字も英語か数字。 Dim intPos As Integer strStatus = "end" If Left(strInput, 1) Like "[a-zA-Z]" Then '連語の場合 Call GetBlank(intPos, strInput) '空白の場所 If intPos > 0 Then strShort = Left(strInput, intPos - 1) '前半の単語 If Right(strShort, 1) Like "[a-zA-Z0-9]*" Then 'チェック strRest = Trim(Mid(strInput, intPos + 1)) '残り strStatus = "continue" Else strStatus = "end" '前の単語に日本語が混ざる場合は分けない End If Else strStatus = "end" '空白がないのでもう単語は含まれない。 End If Else strStatus = "end" '冒頭がアルファベットではないので、もう英単語は含まれない。 End If End Sub Sub GetBlank(intGetBlank, ByVal str1 As String) '最初の半角または全角の空白の場所を探す ' strStatus = hankaku 半角の空白が先 ' strStatus = zenkaku　全角の空白が先 Dim intPos1 As Integer, intPos1z As Integer intPos1 = InStr(str1, " ") '半角の空白 intPos1z = InStr(str1, "　") '全角の空白 If intPos1z > 0 And (intPos1 = 0 Or intPos1z < intPos1) Then ' 全角空白があり、半角空白がないか、あっても後ろの場合に ' 全角空白で区切っている。 intPos1 = intPos1z End If intGetBlank = intPos1 End Sub Sub KeizokuLine() '継続行をマークする。１つの行にまとめる。 Dim wsOutput As Worksheet Dim intRows As Integer, intLine1 As Integer Dim str1 As String, str2 As String Set wsOutput = Worksheets("z単語全部整形") 'すでにあるはず Set wsOutput = ActiveSheet intRows = Range("A65536").End(xlUp).Row '入力データが終わる行 '継続行のマーキング For intLine1 = 1 To intRows str1 = Range("c" & intLine1).Value If str1 <> "" Then If Left(str1, 2) = " " Or Left(str1, 1) = "　" Then '継続行の処理 ' 冒頭が半角空白または全角空白の場合 Range("b" & intLine1).Value = "continue" Range("b" & intLine1).Interior.ColorIndex = 4 ' 緑色 ' strKeizokuNow = "on" End If End If ' 継続行の判定終わり Next '次の行 '継続行を前の行につなげる。　　後ろから処理。前からだと行番号がおかしくなる。 For intLine1 = intRows To 1 Step -1 '後ろから処理する If Range("b" & intLine1).Value = "continue" Then str1 = Trim(Range("c" & intLine1 - 1).Value) str2 = Trim(Range("c" & intLine1).Value) Range("c" & intLine1 - 1).Value = str1 & " " & str2 End If Next ' 継続行の消去。デバックの時は以下をコメントアウトする。 For intLine1 = intRows To 1 Step -1 '後ろから消す str1 = Trim(Range("b" & intLine1).Value) If str1 = "x" Or str1 = "continue" Then Rows(intLine1).Delete End If Next End Sub Sub SeikeiTango() ' 単語行の整形 「・」で始まる場合は「・」を取る。 Dim wsInput As Worksheet, wsNew As Worksheet Dim intRows As Integer, intLine As Integer Dim str1 As String, str2 As String Set wsInput = Worksheets("z単語全部") 'すでにあるはず wsInput.Copy before:=wsInput Set wsNew = ActiveSheet wsNew.Name = "z単語全部整形" intRows = wsNew.Range("A65536").End(xlUp).Row '入力データが終わる行 For intLine = 1 To intRows str1 = Trim(Range("c" & intLine).Value) If Left(str1, 1) = "・" Then ' 冒頭が・の場合は除去。 str2 = Mid(str1, 2) If Trim(str2) = "" Then Range("b" & intLine).Value = "x" Else Range("c" & intLine).Value = str2 End If End If Next End Sub Sub MergeTango() '　単語の記事別ファイルを１つにする。 Dim wsNew As Worksheet, wsArticle As Worksheet Dim intArticle As Integer, intStart As Integer, intEnd As Integer Dim intOut As Integer, intLine As Integer Dim str1 As String Set wsNew = Worksheets.Add() ' 新しいワークシートを作る。 wsNew.Name = "z単語全部" '後で消しやすいように頭にzを付ける。" Set wsNew = ActiveSheet intOut = 1 For intArticle = 1 To intNumArticle Set wsArticle = Worksheets("zb" & intArticle) intStart = Int(Val(wsArticle.Range("c1").Value)) intEnd = Int(Val(wsArticle.Range("d1").Value)) Range("a" & intOut).Interior.ColorIndex = 6 '黄色 For intLine = intStart To intEnd str1 = Trim(wsArticle.Range("a" & intLine).Value) If str1 <> "x" Then Range("a" & intOut).Value = intArticle Range("c" & intOut).Value = wsArticle.Range("b" & intLine).Value intOut = intOut + 1 End If Next ' 次の行へ Next '次の記事へ End Sub Sub GetTango() ' 単語が始まる行と終わる行を決める Dim wsArticle As Worksheet, wsOut As Worksheet Dim intArticle As Integer, intOut1 As Integer, intLine As Integer Dim intStartTango As Integer, intEndTango As Integer Dim intTitle As Integer, intTangoMemo As Integer Dim intEnd As Integer, intBlank As Integer Dim strCompare As String, strStatus As String Dim strPart As String, intPart As Integer, intStart1 As Integer Dim intTime As Integer For intArticle = 1 To intNumArticle '各記事の操作 Set wsArticle = Worksheets("za" & intArticle) wsArticle.Copy before:=wsArticle '　入力ファイルをコピーする。 Set wsOut = ActiveSheet wsOut.Name = "zb" & intArticle intEnd = Range("A65536").End(xlUp).Row '入力データが終わる行 intOut1 = 1 '出力ファイルの出力行を初期化 intStartTango = 1 Range("a:a").Insert 'A列に空白を加えた。主要データはB列に移動した。 Range("b2").Value = "" '２行めを空白にしておく。 intTitle = intTitleTango(intArticle, intEnd) 'タイトル行の決定 Range("3:" & intTitle - 1).Delete ' ３行めからタイトル行直前までカット。 intTitle = 3 '　現在のタイトル行の場所 '-----------単語が始まる行を探す--------------------------- intPart = 0 Call GetStartTango(intStartTango, intPart, intArticle, intTitle) Range("b" & intStartTango).Interior.ColorIndex = 4 '緑色　'後で目で確認 Range("a" & intStartTango).Value = "start" '------------単語の終了行を探す　---------------------------------- For intTime = 1 To 3 'パーツに分けている場合がある。 'パーツは３つまでに対応。 'もっとある場合は増やす。 Call GetEndTango(strStatus, intEndTango, intStartTango, _ intEnd, intArticle, intPart) If strStatus = "done" Then '終了行が見つかったので完了。 Exit For Else intStart1 = intEndTango + 1 Call GetEndTango(strStatus, intEndTango, intStart1, _ intEnd, intArticle, intPart) End If Next Range("b" & intEndTango).Interior.ColorIndex = 6 '黄色　後で目で確認 Range("a" & intEndTango + 1).Value = "end" Range("c1").Value = intStartTango '後で読み出しに使う Range("d1").Value = intEndTango '後で読み出しに使う Range("e1").Value = intPart 'パート数確認のため Next '次の記事へ。 End Sub Sub GetStartTango(intStartTango As Integer, intPart As Integer, _ ByVal intArticle As Integer, ByVal intTitle As Integer) ' 単語が始まる場所を調べる。 Dim strCompare As String Dim intStart As Integer Worksheets("zb" & intArticle).Activate ' ファイルは既にあるはず。 strCompare = Trim(Range("b" & intTitle + 1).Value) 'タイトルの次の行 If strCompare = "" Then '空白ならタイトルの２行先から始まる intStart = intTitle + 2 Else '空白を入れていない記事もある。 intStart = intTitle + 1 End If 'タイトル直後または空白の後に(1)や1)が来た場合（記事番号、53,48,44など） strCompare = Trim(Range("b" & intStart).Value) '記事の始まりの候補行（空白行は除去済） If strCompare Like "[0-9])" Or Left(strCompare, 1) = "-" _ Or Left(strCompare, 1) = "<" Then ' 1), (1)など。(1)はマイナス数字になっている場合もあり。 ' 記事13は、<動詞>などの行を省く Range("a" & intStart).Value = "x" '後で消すためにマーク intPart = 1 ' どのパートか。 intStart = intStart + 1 ' (1)などの行の次から単語が始まる。 End If intStartTango = intStart End Sub Sub GetEndTango(strStatus As String, intEndTango As Integer, _ ByVal intStartTango As Integer, ByVal intEnd As Integer, _ ByVal intArticle As Integer, ByVal intPart As Integer) '単語が終わる場所を探す。続けて最高３回呼び出す。 Dim intLine As Integer Dim strCompare As String, str1 As String Worksheets("zb" & intArticle).Activate 'ワークシートは既にあるはず。 For intLine = intStartTango + 1 To intEnd '単語の終わりを探す strCompare = Trim(Range("b" & intLine).Value) '　入力データを１行読む If Left(strCompare, 5) = "-----" Then ' ----　は終了記号 If Trim(Range("b" & intLine - 1).Value) = "" Then intEndTango = intLine - 2 ' ---の直前が空白の場合 Else intEndTango = intLine - 1 '----の直前が空白でない場合 End If strStatus = "done" Exit For ' ---で区切られていれば、終了行が見つかり完了。 End If If strCompare = "" Then ' 空白行の後はいろいろある。 intEndTango = intLine - 1 Range("a" & intLine).Value = "x" '後で消すためにマーキング strStatus = "may continue" str1 = Trim(Range("b" & intLine + 1).Value) '空白の1行先をチェック If Left(str1, 1) Like "[a-zA-Z]" Then strStatus = "continue" 'もっと下に単語の終わりがある ElseIf str1 Like "[0-9])" Or Left(str1, 1) = "-" Or Left(str1, 1) = "<" Then 'パートがある場合 strStatus = "continue" Range("a" & intLine + 1).Value = "x" intPart = intPart + 1 Else strStatus = "done" ' 空白の１行先が英語や1)などでなければ終了 Exit For End If End If Next End Sub Function intTitleTango(ByVal intArticle As Integer, ByVal intEnd As Integer) As Integer ' 単語メモ、などのタイトル行の場所を取ってくる。 Dim intTitle As Integer, intTangoMemo As Integer, intLine As Integer Dim strCompare As String Worksheets("zb" & intArticle).Activate intTangoMemo = 0 intTitle = 0 For intLine = 1 To intEnd strCompare = Trim(Range("b" & intLine).Value) '入力データを１行読む If Left(strCompare, 4) = "単語メモ" Then '行頭に「単語メモ」と書いた記事対策（記事番号44） intTangoMemo = intLine ElseIf strCompare Like "単語数が多い時" Then '記事番号13対策 ' 次の行へ。 ElseIf Left(strCompare, 2) = "単語" Or Left(strCompare, 3) = "英単語" Then '行頭に特定の単語がある場合 intTitle = intLine Exit For End If Next If intTitle = 0 And intTangoMemo > 0 Then '単語メモのみがある場合はその行。 intTitle = intTangoMemo End If intTitleTango = intTitle End Function Sub CutKiji() '入力データ（全記事が１つのシート）を '各記事のシートに分割する。 Dim wsInput As Worksheet, wsBunkai As Worksheet, wsNew As Worksheet Dim cntl As Integer, cntl2 As Integer Dim intStart As Integer, intEnd As Integer, intOut1 As Integer Set wsInput = Worksheets("単語用") '入力データ Set wsBunkai = Worksheets("z記事の分解") 'GetLineKijiで作った配列を使う。 ' 各記事の開始行と終了行のリスト。 For cntl = 1 To intNumArticle '各記事の操作 Set wsNew = Worksheets.Add() ' 新しいワークシートを作る。 wsNew.Name = "za" & cntl '後で消しやすいように頭にzaを付ける。 intStart = Int(Val(wsBunkai.Range("b" & cntl).Value)) '開始行を得る。 intEnd = Int(Val(wsBunkai.Range("c" & cntl).Value)) '終了行を得る。 intOut1 = 1 '出力ファイルの行を初期化 For cntl2 = intStart To intEnd '入力データから該当行を各記事ファイルにコピー Range("a" & intOut1).Value = wsInput.Range("a" & cntl2).Value intOut1 = intOut1 + 1 '次の出力行へ。 Next Next End Sub Sub ModifyFirst() ' 最初の記事（記事番号最大）のみの処理。開始行を探す。 ' 開始行の書き換え。（"z記事の分解"シートを更新する） Dim wsInput As Worksheet, wsBunkai As Worksheet Dim intKeta As Integer, intEnd As Integer, cntl As Integer Dim strCompare As String Dim strTemp As String, intTemp As Integer '変換用 Set wsInput = Worksheets("単語用") ' 入力データ Set wsBunkai = Worksheets("z記事の分解") '分解用の行番号リスト(更新する） intEnd = wsBunkai.Range("c" & intNumArticle).Value ' 最初の記事（記事番号最大）が終わる行 ' 大きいファイルの途中の行に相当。 intKeta = intNum(intNumArticle) '記事数の桁数 For cntl = intNumArticle To intEnd '最初の何行かは飛ばす必要（記事リストと重複するので） strCompare = wsInput.Range("a" & cntl).Value '　入力データを１行読む strTemp = Left(strCompare, intKeta) '最初の何桁か読む。 intTemp = Int(Val(strTemp)) '文字を整数化。 If intTemp = intNumArticle Then '記事番号に等しいか。 '開始行発見 wsBunkai.Range("b" & intNumArticle).Value = cntl 'データ修正 Exit For '１つ見つかったらループから出る。 End If Next End Sub Sub GetLineKiji() '記事全体のファイルから、各記事が始まる行番号のリストを取ってくる。 Dim wsNew As Worksheet, wsInput As Worksheet Dim intArticle As Integer, intLenCheck As Integer, intOut As Integer Dim cntl As Long, lngRowsInput As Long Dim strCheck As String, strCompare As String Set wsInput = Worksheets("単語用") '入力データ Set wsNew = Worksheets.Add() ' 新しいワークシート wsNew.Name = "z記事の分解" '後で消しやすいように頭にzを付ける。 intArticle = intNumArticle '記事番号は最大から１個ずつ減る。 lngRowsInput = wsInput.Range("A65536").End(xlUp).Row '入力データが終わる行 strCheck = "posted by ティー at" '記事の終わりを表す表現 intLenCheck = Len(strCheck) '長さを得る。 intOut = 1 '出力ファイルの行を初期化 Range("b1").Value = 1 '始まりの行 For cntl = 1 To lngRowsInput '　入力データを１行ずつ見る。 strCompare = wsInput.Range("a" & cntl).Value '入力データを１行読む If Left(strCompare, intLenCheck) = strCheck Then '記事の区切りが来る。 Range("a" & intOut).Value = intArticle ' 記事番号を出力 Range("c" & intOut).Value = cntl '終わりの行番号をＣ列に書く。 If intArticle > 1 Then '　入力データの最後の記事（記事番号１）は除外。 Range("b" & intOut + 1).Value = cntl + 2 '次の記事の始まりの行番号を下の行のB列に書く。 End If intArticle = intArticle - 1 '記事番号は降順 intOut = intOut + 1 '出力ファイルの次の行へ。 End If Next End Sub Sub Seiretsu(strInput As String) '入力ファイルの項目を整列させる Dim ws1 As Worksheet Set ws1 = Worksheets(strInput) '入力シートの名前 ws1.Range("A1").Sort key1:=ws1.Range("A1"), order1:=xlAscending, header:=xlNo End Sub Sub DeleteSheets() ' いらないシートを消す。冒頭がzかSheetの場合。 ' Dim ws1 As Worksheet Application.DisplayAlerts = False ' 窓が出ないようにする。 For Each ws1 In ActiveWorkbook.Sheets If Left(ws1.Name, 1) = "z" Or Left(ws1.Name, 5) = "Sheet" Then 'シート名の判断 ws1.Delete 'シートの消去 End If Next ws1 Application.DisplayAlerts = True '　窓が出るように戻す。 End Sub Sub MakeNumTitleHtml() ' makes list of title numbers by html format '入力データのシートから、タイトル行を選び、タイトル番号を 'html形式で新しいシートに出す ' Dim wsTitle As Worksheet, wsNew As Worksheet Dim lngRowsInput As Long, lngRow1 As Long, cntl As Long Dim intLenStart1 As Integer, intLenNum As Integer Dim intPos1 As Integer, intPos2 As Integer Dim strCompare As String, strStarthref1 As String Dim strStarthref2 As String, strEndhref1 As String Dim strNumTitle As String, strNum As String, strOutStart As String Set wsTitle = Worksheets("タイトル用") '入力データ Set wsNew = Worksheets.Add() ' 新しいワークシート wsNew.Name = "z記事番号" 'シート名の前にzを付けて、後で消しやすくする。 strStarthref1 = "= 1 Then '冒頭が数字の場合のみ strNum = Left(strNumTitle, intLenNum) '数字部分を取ってくる。 Range("a" & lngRow1).Value = strNum 'タイトル番号のみ（インデックス用） Range("b" & lngRow1).Value = strOutStart & strNum & strEndhref1 'タイトル番号のhtml記法 lngRow1 = lngRow1 + 1 ' 出力ファイルの次の行 End If End If 'trackbackとcommentのチェック End If '最初が数字か。 Next '入力データの次の行へ。 intNumArticle = lngRow1 - 1 '全部の記事数が確定。この後の変更はない。 End Sub Function intNum(ByVal str1 As String) As Integer ' '　冒頭の数字が何桁あるかチェックする。 ' 冒頭が数字でない場合は、0を返す。 ' IsNumericは「.」を小数点と解釈してしまうので、条件文後半で除去する。 ' 入力ファイルで数字の後のピリオドは書き忘れる場合があるかも。 Dim num1 As Integer num1 = 1 Do While IsNumeric(Mid(str1, num1, 1)) And Mid(str1, num1, 1) <> "." num1 = num1 + 1 Loop intNum = num1 - 1 End Function