人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

質問です
c:\test\のホルダーの中に複数の拡張子CSVのファイルがあります
CSVファイルの中のデータはA列A1から文字列であります

その中の行のセルのいくつかにダブルコーテーションに囲まれた中に複数のデータがあるセルがあります
TXTでみると
"aaaa
bbbb
cccc
dddd
"
の状態になっています
そのセルがどのファイルにあるかわかりませんマクロで探してどのファイルのA列の何行目に
あるか実行ファイルのsheet1に表記できるマクロをおねがいします

ちなみにマクロでその中のセルのいくつかにダブルコーテーションに囲まれた複数のデータ
を行列にもどすことは可能でしょうか


●質問者: inosisi
●カテゴリ:コンピュータ インターネット
○ 状態 :終了
└ 回答数 : 1/1件

▽最新の回答へ

1 ● oil999
●100ポイント ベストアンサー

以下のマクロをお試しください。

A列だけ存在するという前提です。
ご質問にあったイレギュラーなデータは分解して、CSVに収め直すようにしてあります。
また、イレギュラーなデータが見つかったら、シート"LOG"に残すようにしてあります。A列にディレクトリ、B列にファイル名、C列に行番号が入ります。

Option Explicit

Private logSheet As String
Private logRow As Long

'ログシート作成
Private Sub makeLogSheet()
 Dim ws As Worksheet
 Dim flag As Boolean
 
 logSheet = "LOG"
 flag = False
 For Each ws In Worksheets
 If ws.Name = logSheet Then flag = True
 Next ws
 If (flag = True) Then
 Worksheets(logSheet).Cells.Clear
 Else
 Set ws = Worksheets.Add
 ws.Name = logSheet
 End If
 logRow = 1
End Sub

'処理結果をログシートに残す
Private Sub putLog(path As String, fname As String, ln As Long)
 Worksheets(logSheet).Cells(logRow, 1) = path
 Worksheets(logSheet).Cells(logRow, 2) = fname
 Worksheets(logSheet).Cells(logRow, 3) = ln
 logRow = logRow + 1
End Sub

'1行処理
Function convRow2(sour As String, ln As Long, path As String, fname As String) As String
 Dim dest As String
 dest = Replace(sour, vbCrLf, """" & vbCrLf & """")
 dest = Replace(dest, vbCrLf & """""", "")
  'ログシートに書き出す
 If (sour <> dest) Then Call putLog(path, fname, ln)
 convRow2 = dest
End Function

'1行読み込み:イレギュラー対応版
Function hogeLineInput(n As Integer)
 Dim sour As String, dest As String, c As String, q As String
 Dim i As Long, ln As Long

 dest = ""
 If (EOF(n) = False) Then
 Do
 Line Input #n, sour
 ln = Len(sour)
 For i = 1 To ln
 c = Mid(sour, i, 1)
  'ダブルクォーテーション
 If (c = """") Then
 If (q = "") Then
 dest = """"  '最初のクォーテーションの前の文字は無視
 q = """"
 ElseIf (q = """") Then
 dest = dest & c
 q = ""
 i = ln
 End If
 Else
 dest = dest & c
 End If
 Next i
 If q = """" Then dest = dest & vbCrLf
 Loop While (EOF(n) = False) And q = """"
 End If
 hogeLineInput = dest
End Function

'1ファイル処理
Sub convFile(path As String, fname As String)
 Dim ln As Long
 Dim buf As String
 Dim fname1 As String, fname2 As String
 fname1 = path & fname
 fname2 = path & fname & ".$$$"
 Open fname1 For Input As #1
 Open fname2 For Output As #2
 ln = 1
 Do Until EOF(1)
 buf = hogeLineInput(1)
 buf = convRow2(buf, ln, path, fname)
 If (buf <> "") Then Print #2, buf
 ln = ln + 1
 Loop
 Close #1
 Close #2
 Kill fname1  'オリジナル・ファイル削除
 Name fname2 As fname1
End Sub

'ファイル探索+処理実行
Sub hogeConv(path As String, ext As String)
 Dim fcol As Object, re As Object
 Dim flist As Variant, remat As Variant
 Dim pat As String
  'サブディレクトリ探索
 Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).SubFolders
 For Each flist In fcol
 Call hogeConv(path & flist.Name & "/", ext)
 Next flist
 Set fcol = Nothing
  '処理対象ファイル探索+処理実行
 Set fcol = CreateObject("Scripting.FileSystemObject").GetFolder(path).Files
 Set re = CreateObject("VBScript.RegExp")
 pat = "\." & ext & "$"
 With re
 .Pattern = pat
 .IgnoreCase = True
 .Global = True
 For Each flist In fcol
 Set remat = .Execute(flist.Name)
 If remat.Count > 0 Then Call convFile(path, flist.Name)
 Next flist
 End With
 Set re = Nothing
 Set fcol = Nothing
End Sub

Sub main()
 Call makeLogSheet
 Call hogeConv("C:/test/", "csv")
End Sub

inosisiさんのコメント
大変遅くなりました 身内に不幸があったものですから ありがとうございました 上手くいきました何かありましたら質問させていただきます
関連質問

●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ