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

質問です
C:\TEST\のフォルダーに複数のcsvファイルがあります

そのファイル名と同じ文字をS列にデータのある行(最終行)の分だけ記入コピーするマクロをお願いします

行データは1行目からあります
列データはA列からR列まであります

できれば途中に空白行があっても最終行まで記入できと助かります
処理速度はできるだけ早くおねがいします
よろしくお願いします

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

▽最新の回答へ

質問者から

データ行はA列のデータ(文字列)行数の分だけでよいです
A列に空白行がある場合もあります
もし空白行があってマクロが実行できない場合は空白行を削除またはソート
して空白行をなくす方法があれば助かりますその後マクロが継続してエラーにならないようにできれば良いのですが

C:\TEST\の複数のCSVファイルは連続してマクロ実行できること


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

処理後、オリジナルのファイルは "*.bak" にリネームして同じフォルダに残しています。
空白行のS列にもファイル名を入れます。

Option Explicit

Function addColS(buf As String, str As String, sep As String) As String
 Dim pos1, pos2 As Integer
 Dim i, ix1, ix2 As Integer
 Dim items() As Variant, item As Variant
 Dim S As Integer
 
 S = 19  'S列の番号
 pos1 = 1
 ix1 = 0
 ReDim items(ix1)
  'sepでカラムを分割
 Do While pos1 <= Len(buf)
 pos2 = InStr(pos1, buf, sep, vbTextCompare)
 If pos2 < pos1 Then
 pos2 = Len(buf) + 1
 End If
 ReDim Preserve items(ix1)  '配列要素数を再設定
 items(ix1) = Trim$(Mid$(buf, pos1, pos2 - pos1))
  ' シングルクォーテーション、ダブルクォーテーションで囲まれている場合は両端文字を取り除く
 If (((Left$(items(ix1), 1) = """") And (Right$(items(ix1), 1) = """")) Or ((Left$(items(ix1), 1) = "'") And (Right$(items(ix1), 1) = "'"))) Then
 items(ix1) = Trim$(Mid$(items(ix1), 2, Len(items(ix1)) - 2))
 End If
 pos1 = pos2 + 1
 ix1 = ix1 + 1
 Loop

  'S列にstrを追加
 ix1 = 1
 For Each item In items
 If (ix1 = 1) Then
 addColS = item
 ElseIf (ix1 = S) Then
 addColS = addColS & "," & str
 Else
 addColS = addColS & "," & item
 End If
 ix1 = ix1 + 1
 Next
 For i = ix1 To S
 If (i = S) Then
 addColS = addColS & "," & str
 Else
 addColS = addColS & ","
 End If
 Next i
End Function
c
'1ファイル処理
Sub addFileName(path As String, fname As String)
 Dim buf As String, idx As String
 Dim fname2 As String, fname3 As String
 
  'CSVファイル読み込み&書き込み
 fname2 = path & fname
 fname3 = path & fname & ".bak"
 Name fname2 As fname3
 Open fname3 For Input As #1
 Open fname2 For Output As #2
 Do Until EOF(1)
 Line Input #1, buf
 buf = addColS(buf, fname, ",")  'S列にパス名+ファイル名を入れたい場合は、第2引数をfname2にしてください
  '半角カンマ区切り以外の場合は第3引数を変更してください
 Print #2, buf
 Loop
 Close #2
 Close #1
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, fname As String
 Dim n As Long
 
  '処理対象ファイル探索+処理実行
 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 addFileName(path, flist.name)
 End If
 Next flist
 End With
 Set re = Nothing
 Set fcol = Nothing
End Sub

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

inosisiさんのコメント
ありがとうございます subまたはFunctionが定義されていません のエラーメッセージがでます原因はなんでしょうか

inosisiさんのコメント
S列にファイル名だけ入れたい場合はこのままで良いのでしょうか

inosisiさんのコメント
'ファイル探索+処理実行 Sub hogeConv(path As String, ext As String) ここが黄色 fname = GetFNameFromFStr(flist.Name) が反転黒

oil999さんのコメント
> S列にファイル名だけ入れたい場合 パス名が不要であれば、このままで動くはずです。

inosisiさんのコメント
お世話様です fname = GetFNameFromFStr(flist.Name) を fname = (flist.Name) に修正したら直りました 質問ですが BAKファイルを作らない場合はどのように修正 すれば良いのでしょうか よろしくお願いします
関連質問

●質問をもっと探す●



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