テキストファイルをEXCELに取り込んで処理を行う例
EXCEL VBAビギナーのbonlifeです。人力検索はてなで仕事でも時折使えそうな質問(http://q.hatena.ne.jp/1151842104)が出ていたので、回答を準備してみました。
VBAでテキストファイルを指定した区切り文字で分割して取り込み、後処理を行う、という流れです。取り込むファイルに区切り文字ではない値としてのスペースが含まれていたり、括弧の対応が合っていなかったりすると上手く動きません。ポイントはOpenTextだけですね。中盤部分の後処理では泥臭い処理になってしまっています…。VBAには慣れてないのでよく分かりませんが、Line Inputステートメントを使って1行ずつ処理してからEXCELに取り込んだ方が良いのかもしれないです。まぁ、このソースでも読み込むファイルのサイズが極端に大きくなければ問題なく動作するはずですので、ご安心を。繰り返し頻度が少ない処理であれば、秀丸マクロで正規表現使ってアレコレやってタブ区切りにしたデータをEXCELに貼り付ける方が簡単だと思いました。
Sub importText() Dim importFile As String Dim rowNum As Integer Dim colNum As Integer importFile = Application.GetOpenFilename _ (, , , , False) ' カンマ(,)、スペース( )、イコール(=)を区切り文字としてデータ取り込み Workbooks.OpenText Filename:=importFile, _ DataType:=xlDelimited, _ comma:=True, _ Space:=True, _ other:=True, _ otherchar:="=", _ FieldInfo:=Array(Array(0, 2),Array(1, 2),Array(2, 2),Array(3, 2)) ' IDの値の前ゼロ対策 ' 命令文、IDという文字列を削除 Columns("B:C").Delete Shift:=xlToLeft rowNum = 1 colNum = 1 ' 1行目から1列目が空でない行が出現するまでの間、行ごとに処理を実行 While (Cells(rowNum, 1).Value <> "") ' 1列目から空でない列が出現するまでの間、列ごとに処理を実行 While (Cells(rowNum, colNum).Value <> "") ' OPTで始まる列の削除 If (Left(Cells(rowNum, colNum).Value, 3) = "OPT") Then Cells(rowNum, colNum).Delete Shift:=xlToLeft ' セル内の()の削除 ElseIf Left(Cells(rowNum, colNum).Value, 1) = "(" And Right(Cells(rowNum, colNum).Value, 1) = ")" Then Cells(rowNum, colNum).Value = Mid(Cells(rowNum, colNum).Value, 2, Len(Cells(rowNum, colNum).Value) - 2) colNum = colNum + 1 ' ()で囲まれた複数の値が複数セルに分かれてしまった部分の対応 ' セルの先頭の文字、セルの最後の文字によって処理を分ける ' 次のセルの末尾が")"でない間、セルに","と次のセルの値を足し、次のセルを削除 ElseIf Left(Cells(rowNum, colNum).Value, 1) = "(" Then While (Right(Cells(rowNum, colNum + 1).Value, 1) <> ")") Cells(rowNum, colNum).Value = Cells(rowNum, colNum).Value + "," + Cells(rowNum, colNum + 1).Value Cells(rowNum, colNum + 1).Delete Shift:=xlToLeft Wend ' 次のセルの末尾が")"になった場合、 ' セルの先頭の1文字を削除したもの、","、次のセルの最後の1文字を削除したものを結合 ' 次のセルを削除し、次のセルに移動 Cells(rowNum, colNum).Value = Right(Cells(rowNum, colNum).Value, Len(Cells(rowNum, colNum).Value) - 1) + "," + Left(Cells(rowNum, colNum + 1).Value, Len(Cells(rowNum, colNum + 1).Value) - 1) Cells(rowNum, colNum + 1).Delete Shift:=xlToLeft colNum = colNum + 1 Else colNum = colNum + 1 End If Wend colNum = 1 rowNum = rowNum + 1 Wend ' 整形 (列幅の調整、フォントの変更) Cells.Select With Selection.Font .Name = "Courier New" End With Cells.EntireColumn.AutoFit Cells(1, 1).Select ' 別名で保存 (元ファイルの末尾に保存日時を付加し保存、ファイルを閉じる) ActiveWorkbook.SaveAs Filename:= _ importFile + "_" + Format(Now(), "yyyymmddhhnnss") + ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False ActiveWorkbook.Close End Sub
[参考URL]