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

エクセルVBAの質問です。
シートに貼り付けたコマンドボタンを押すと次の動作ができるようにしたいです。

■ローカルフォルダにあるカンマ区切りのテキストを、フォルダすべてのファイルすべて読み込み、カンマの区切りに沿って、セルごとに分割して表示する。


できますでしょうか。
よろしくお願いいたします。

●質問者: clinejp
●カテゴリ:コンピュータ
✍キーワード:VBA エクセル コマンド セル テキスト
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● slowstrawberry
●23ポイント

可能でしょう。次のようにします。

コマンドボタンを押したときのイベントとして、

フォルダを開く→FOR文などでそのフォルダ内のファイルを次々巡回するようにして→そのファイルからカンマ区切りでセルに次々入力。

この様にします。

データを読み込む方法として以下のURL等がよさげです。

http://officetanaka.net/excel/vba/file/file08.htm


2 ● SALINGER
●23ポイント

ボタンに処理の関連付けは先の質問のK_SUKEさんが答えてましたので省略して

実装するコードを

Private FSO

Private Sub CommandButton1_Click()
  'CSVファイルの入っているフォルダーのパスをしていしてください
 Const fpath As String = "C:\Documents and Settings\hogehoge\デスクトップ\CSVDATA"
 Set FSO = CreateObject("Scripting.FileSystemObject")
 Call getFile(fpath)
 Set FSO = Nothing
End Sub

Private Sub getFile(fpath As String)
 Dim myFile
 Dim myFolder
 Dim objTS
 Dim x() As String
 Dim i As Long
 Dim j As Long
 Dim NewWS As Worksheet
 For Each myFile In FSO.GetFolder(fpath).Files
 i = 1
 Set NewWS = Worksheets.Add
 Set objTS = FSO.getFile(myFile.Path).OpenAsTextStream
 While Not objTS.AtEndOfStream
 x = Split(objTS.readline, ",")
 For j = 1 To UBound(x)
 NewWS.Cells(i, j).Value = x(j - 0)
 Next j
 i = i + 1
 Wend
 objTS.Close
 Next myFile
 For Each myFolder In FSO.GetFolder(fpath).SubFolders
 Call getFile(myFolder.Path)
 Next myFolder
 
 Set objTS = Nothing

End Sub

CSVの形式(””で囲ってたり)によっていろいろと細かい作り直しは必要かもしれませんが、

基本的には、複数のファイルの取得、CSVの読み込み、シートの追加なんかを押さえておけば応用がきくと思います。

http://q.hatena.ne.jp/


3 ● izumi-0620
●22ポイント

可能です。

開いたcsvファイル(縦に1列データが並ぶ)を1つのシートに並べて貼り付ける例です。

Sub main()

sWorkBookName = ThisWorkbook.Name

With Application.FileSearch

.NewSearch

.SearchSubFolders = False

.LookIn = Sheet1.TextBox1 'カンマ区切りファイルのある場所

.Filename = "*.*" '小文字大文字の判別なし、"."が必要

If .Execute(SortBy:=msoSortByFileName, _

SortOrder:=msoSortOrderAscending) > 0 Then

For iFileCount = 1 To .FoundFiles.Count

'Dataのオープン

Workbooks.Open Filename:=.FoundFiles(iFileCount)

Range(Cells(1, 1), Cells(1000, 1)).Select

Selection.Copy

'Sheet2への貼付

Workbooks(sWorkBookName).Activate

Sheet2.Activate

i = GetStartColumn()

sDataName = GetFileName(.FoundFiles(iFileCount))

Cells(1, i).Select

ActiveSheet.Paste

Workbooks(sDataName).Close

Next

End If

End With

End Sub

Function GetStartColumn()

i = 1

While Cells(1, i) <> ""

i = i + 1

Wend

GetStartColumn = i

End Function

dummy URL:http://www.yahoo.co.jp


4 ● slowstrawberry
●22ポイント

サンプルを作成しました。

Option Explicit


Private Sub CommandButton1_Click()
 Const cnsYEN = "\"
 Const cnsTITLE = "テキストファイル読み込み処理"
 Const cnsFILTER = "全てのファイル (*.*),*.*"
 Dim xlAPP As Application  ' Excel.Application
 Dim objWBK As Workbook  ' ワークブックObject
 Dim strPATHNAME As String  ' 指定フォルダ名
 Dim strFILENAME As String  ' 検出したファイル名
 Dim strOPENFILE As String  ' ファイル名フルパス
 Dim swESC As Boolean  ' Escキー判定
 Dim shell As Object  ' シェルオブジェクト
 Dim intFF As Integer  ' FreeFile値
 Dim X() As Variant  ' 読み込んだレコード内容
 Dim IX1 As Long  ' CSV項目カラムINDEX
 Dim GYO As Long  ' 収容するセルの行
 Dim lngREC As Long  ' レコード件数カウンタ
 Dim strREC As String  ' レコード領域
 Dim POS1 As Long  ' レコード文字位置INDEX
 Dim POS2 As Long  ' レコード文字位置INDEX
 
  ' 「フォルダの参照」よりフォルダ名の取得
 strPATHNAME = BrowseForFolder("フォルダを指定して下さい", True)
 If strPATHNAME = "" Then Exit Sub

  ' 指定フォルダ内のファイル名を参照する(1件目)
 strFILENAME = Dir(strPATHNAME & "\*.txt", vbNormal)
 If strFILENAME = "" Then
 MsgBox "このフォルダにはtextファイルがありません"
 Exit Sub
 End If

 Set xlAPP = Application
 With xlAPP
 .ScreenUpdating = False  ' 画面描画停止
 .EnableEvents = False  ' イベント動作停止
 .EnableCancelKey = xlErrorHandler  ' Escキーでエラートラップする
 .Cursor = xlWait  ' カーソルを砂時計にする
 End With
 On Error GoTo Button1_Click_ESC
  ' 指定フォルダの全txtについて繰り返す
 Do While strFILENAME <> ""
  ' Escキー打鍵判定
 DoEvents
 If swESC = True Then
  ' 中断するのかをメッセージで確認
 If MsgBox("中断キーが押されました。ここで終了しますか?", _
 vbInformation + vbYesNo) = vbYes Then
 GoTo Button1_Click_EXIT
 Else
 swESC = False
 End If
 End If

  '-----------------------------------------------------------------------
  ' ↓↓↓ 検索した1ファイル単位の処理 ↓↓↓
  ' FreeFile値の取得(以降この値で入出力する)
 intFF = FreeFile
  ' 指定ファイルをOPEN(入力モード)
 strOPENFILE = strPATHNAME & "\" & strFILENAME
 Open strOPENFILE For Input As #intFF
  ' ファイルのEOF(End of File)まで繰り返す
 Do Until EOF(intFF)
  ' レコード件数カウンタの加算
 lngREC = lngREC + 1
  ' 行単位にレコードを読み込む
 Line Input #intFF, strREC  ' ?

  ' LineInputより自分で半角カンマを探しCSV→項目分割させる
 POS1 = 1
 IX1 = 0
 ReDim X(IX1)  ' 配列を初期化
 Do While POS1 <= Len(strREC)
 POS2 = InStr(POS1, strREC, ",", vbTextCompare)
 If POS2 < POS1 Then
 POS2 = Len(strREC) + 1
 End If
 ReDim Preserve X(IX1)  ' 配列要素数を再設定
 X(IX1) = Trim$(Mid$(strREC, POS1, POS2 - POS1))
 POS1 = POS2 + 1
 IX1 = IX1 + 1
 Loop
  ' 行を加算しレコード内容を表示(先頭は2行目)
 GYO = GYO + 1
 If IX1 >= 1 Then
 Range(Cells(GYO, 1), Cells(GYO, IX1)).Value = X  ' 配列渡し ?
 End If
 Loop
  ' 指定ファイルをCLOSE
 Close #intFF
  ' ↑↑↑ 検索した1ファイル単位の処理 ↑↑↑
  '-----------------------------------------------------------------------
  ' 次のファイル名を参照
 strFILENAME = Dir
 Loop
 GoTo Button1_Click_EXIT

  '----------------
  ' Escキー脱出用行ラベル
Button1_Click_ESC:
 MsgBox Err.Description

  '----------------
  ' 処理終了
Button1_Click_EXIT:
 With xlAPP
 .StatusBar = False  ' ステータスバーを復帰
 .EnableEvents = True  ' イベント動作再開
 .EnableCancelKey = xlInterrupt  ' Escキー動作を戻す
 .Cursor = xlDefault  ' カーソルをデフォルトにする
 .ScreenUpdating = True  ' 画面描画再開
 End With
 Set objWBK = Nothing
 Set xlAPP = Nothing
End Sub

上のコードを使うには下記のモジュールをダウンロードしてインポートしてください。

↓このページのmodSHBrowseForFolderAPI3.exeを展開して、modAPIBrowseForFolder3.basをインポートする。

http://www.asahi-net.or.jp/~ef2o-inue/download/sub09_020_110.htm...

上の参考サイトのコードをスケルトンにしてコードを書いたので、上記のサイトを参考にいろいろ変えて使えると思います。

関連質問


●質問をもっと探す●



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