| |
▼たろー さん：
>はじめまして。
>
>ＰＬ／ＳＱＬで作成したファイルを、
>エクセルに取り込む際に、コメント行を削除した状態で
>エクセルに一括取り込みを実施したいと思っています。
>
>ファイル取り込み処理は実現できたのですが、
>コメント行の削除がどうしてもうまくできません。
>（よい実装方法が思いつかない）
>
>どなたか効率よく実現できる方法ご存知ないでしょうか？
>
>ちなみに、下記の２種類のパターンを想定しています。
> 1. --で始まる対象行（--〜改行コードまでの１行）
> 2. /* 〜 */の間 （複数行に跨ぐ場合あり）
>
>よろしくお願いします。
良く解らないけど？
テクストファイルとして扱うとすれば、こんなので善いのかな？
Option Explicit
Public Sub Sample()
Dim i As Long
Dim dfn As Integer
Dim vntFileName As Variant
Dim strBuff As String
Dim bytBuff() As Byte
Dim strResult() As String
vntFileName = Application.GetOpenFilename("全て (*.*),*.*")
If VarType(vntFileName) = vbBoolean Then
Exit Sub
End If
dfn = FreeFile
Open vntFileName For Binary As dfn
ReDim bytBuff(1 To LOF(dfn))
Get #dfn, , bytBuff
Close #dfn
strBuff = StrConv(bytBuff, vbUnicode)
Erase bytBuff
DeleteData1 strBuff
DeleteData2 strBuff
strResult = Split(strBuff, vbCrLf)
ActiveSheet.Range("A1").Resize(UBound(strResult) + 1) _
= Application.WorksheetFunction.Transpose(strResult)
MsgBox "処理が完了しました", vbInformation
End Sub
Private Sub DeleteData1(strData As String)
' 1. --で始まる対象行（--〜改行コードまでの１行）
Const cstrFind As String = "--"
Dim i As Long
Dim lngPos1 As Long
Dim lngPos2 As Long
lngPos1 = InStr(1, strData, cstrFind, vbBinaryCompare)
Do Until lngPos1 = 0
lngPos2 = InStr(lngPos1 + 1, strData, vbCrLf, vbBinaryCompare)
If lngPos2 = 0 Then
Exit Do
End If
strData = Left(strData, lngPos1 - 1) & Mid(strData, lngPos2)
lngPos1 = InStr(1, strData, cstrFind, vbBinaryCompare)
Loop
End Sub
Private Sub DeleteData2(strData As String)
' 2. /* 〜 */の間 （複数行に跨ぐ場合あり）
Const cstrFind1 As String = "/*"
Const cstrFind2 As String = "*/"
Dim i As Long
Dim lngPos1 As Long
Dim lngPos2 As Long
lngPos1 = InStr(1, strData, cstrFind1, vbBinaryCompare)
Do Until lngPos1 = 0
lngPos2 = InStr(lngPos1 + 1, strData, cstrFind2, vbBinaryCompare)
If lngPos2 = 0 Then
Exit Do
End If
strData = Left(strData, lngPos1 - 1) & Mid(strData, lngPos2 + 2)
lngPos1 = InStr(1, strData, cstrFind1, vbBinaryCompare)
Loop
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
