Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

3560 / 76735

←次へ　｜　前へ→


	【78804】Re:VBAに行き詰りました。助けてください。

β - 17/2/4(土) 0:42 -


	引用なし

	パスワード

▼りりさん：

とりあえず書いてみました。

Sub Sample()
　　Dim fso As Object
　　Dim txt As Object
　　Dim buf As String
　　Dim fle As Object
　　Dim i As Long
　　Dim fPath As String
　　Dim ext As String
　　Dim shT As Worksheet
　　
　　With Application.FileDialog(msoFileDialogFolderPicker)
　　　　If Not .Show Then Exit Sub　'キャンセルボタン
　　　　fPath = .SelectedItems(1)　 '選択されたフォルダパス文字列
　　End With
　　
　　Application.ScreenUpdating = False　'画面の更新を抑止する
　　
　　Set fso = CreateObject("Scripting.FileSystemObject")
　　
　　Set shT = ThisWorkbook.Sheets("Sheet1")
　　
　　shT.UsedRange.ClearContents
　　　　
　　With shT.Range("B2:E2")　　'見出しを付ける
　　　　.Value = Array("ファイル名", "ファイル種別", "文字数", "半角の有無")
　　　　.Interior.Color = vbBlack
　　　　.Font.Color = vbWhite
　　　　.HorizontalAlignment = xlCenter　　'セルの中の文を中央揃えにする
　　End With
　　
　　i = 3　　'記入示開始行
　　
　　For Each fle In fso.GetFolder(fPath).Files　'指定フォルダ内のファイルを抽出
　　　　ext = fso.GetExtensionName(fle.Name)　　'拡張子
　　　　If LCase(ext) = "txt" Then　 'txtファイルのみを対象
　　　　　　With fso.OpenTextFile(Filename:=fle.Path, IOMode:=1)　'1:ForReading
　　　　　　　　buf = .ReadAll　'全体を一括読みこみ
　　　　　　　　buf = Replace(Replace(buf, vbLf, ""), vbCr, "") '改行コードを削除
　　　　　　　　shT.Cells(i, "B").Value = fso.GetBaseName(fle.Name)　　 '拡張子を除いたファイル名
　　　　　　　　shT.Cells(i, "C").Value = ext
　　　　　　　　shT.Cells(i, "D").Value = Len(buf)
　　　　　　　　shT.Cells(i, "E").Value = IIf(Len(buf) * 2 <> LenB(StrConv(buf, vbFromUnicode)), "有", "無")
　　　　　　　　.Close　　　　　'テキストファイルを閉じる
　　　　　　　　i = i + 1　　　 '次の記入行
　　　　　　End With
　　　　End If
　　Next
　　　　
End Sub

1 hits

▼

【78796】VBAに行き詰りました。助けてください。 りり 17/2/2(木) 14:52