お世話になります。
表題につき過去にここで教わって（https://okwave.jp/qa/q10129448.html）
毎月数千件のPDFファイルの一覧を作成して非常に助かっているのですが、最近対象ファイルにエクセルやワードもリストアップしたくコードの一部に対象ファイルの拡張子を付け加えてみたのですが、の追加により検索対象フォルダが第1階層までしか検索しなくなってしまっていることに気付きました。
どこを修正すれば良いのでしょう。
★修正前コード（指定のフォルダ内の子や孫フォルダまで検索）
'PDFファイルを個々に取得(対象拡張子)
For Each objFile In FSO.GetFolder(path).Files
If UCase(FSO.GetExtensionName(objFile.path)) = "PDF" Then
execute objFile
End If
Next
☆修正後（親フォルダしか検索しなくなった）
'PDFファイルを個々に取得(対象拡張子)
For Each objFile In FSO.GetFolder(path).Files
If UCase(FSO.GetExtensionName(objFile.path)) = "DOCX" Or _
UCase(FSO.GetExtensionName(objFile.path)) = "XLSM" Or _
UCase(FSO.GetExtensionName(objFile.path)) = "PDF" Then
execute objFile
End If
Next
お世話になります。
表題につき過去にここで教わって（https://okwave.jp/qa/q10129448.html）
毎月数千件のPDFファイルの一覧を作成して非常に助かっているのですが、最近対象ファイルにエクセルやワードもリストアップしたくコードの一部に対象ファイルの拡張子を付け加えてみたのですが、の追加により検索対象フォルダが第1階層までしか検索しなくなってしまっていることに気付きました。
どこを修正すれば良いのでしょう。
★修正前コード（指定のフォルダ内の子や孫フォルダまで検索）
'PDFファイルを個々に取得(対象拡張子)
For Each objFile In FSO.GetFolder(path).Files
If UCase(FSO.GetExtensionName(objFile.path)) = "PDF" Then
execute objFile
End If
Next
☆修正後（親フォルダしか検索しなくなった）
'PDFファイルを個々に取得(対象拡張子)
For Each objFile In FSO.GetFolder(path).Files
If UCase(FSO.GetExtensionName(objFile.path)) = "DOCX" Or _
UCase(FSO.GetExtensionName(objFile.path)) = "XLSM" Or _
UCase(FSO.GetExtensionName(objFile.path)) = "PDF" Then
execute objFile
End If
Next
かなりデータ量が多い（10万レコード超）CSVファイルが、100件近くあります。これをエクセルに取り込んで順次同じような作業をしようと思っています。とりあえずCSVを以下のコードで開いています。
Sub CSV入力4() 'クエリーテーブルを使ったCSV読み込みVBAコード
Dim myFile As Variant
myFile = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv", Title:="CSVファイルの選択")
If myFile = False Then
Exit Sub
End If
ActiveSheet.Cells.Clear
With ActiveSheet.QueryTables.Add(Connection:="text;" & myFile, Destination:=Range("A1"))
' .TextFilePlatform = 932 'Shift_Jis
.TextFilePlatform = 65001 'UTF8
.TextFileCommaDelimiter = True
.Refresh BackgroundQuery:=False
.Delete
End With
MsgBox "読込完了"
End Sub
問題は、CSVに拡張子で区別できないUTF-8のCSVファイルがあることです。事前にわかっていれば
.TextFilePlatform = 932 'Shift_Jis
.TextFilePlatform = 65001 'UTF8
の使い分けで対応できるのですが、開いてみて文字化けがあるかどうか調べないとわかりません。自動的に判定する方法はないでしょうか？
あるxmlファイルを一旦テキストファイルにして
そこから数値をエクセルファイルに移行して
ひとつはM.xlsxとし
それに続いて行列を入れ替えた
エクセルファイルR.xlsxを
作りたいのですが
M.xlsx R.xlsxのそれぞれを作るコードを
単純に 合体させただけでは
どうも できません
M.xlsxだけ また R.xlsxだけの
作成するコードは 出来たのですが
それぞれ別のマクロとして実行することになります
ひとつのマクロでM.xlsx R.xlsx同時に
作成するVBAコードは可能でしょうか
宜しくお願い致します
ちなみに該当コードを単純化して
合体したのが以下のものです
win10 office10
Sub 783縦()
Dim FileName As Variant
ChDir "\\DESKTOP-O5\f"
FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml")
If FileName = False Then
MsgBox "キャンセルされました"
Exit Sub
End If
FileCopy FileName, Left(FileName, InStrRev(FileName, "\")) & "テキスト.txt"
Const MyFile = "\\DESKTOP-O5\f\テキスト.txt"
Const Key1 = "<Name>"
Const Key2 = "</Name>"
Const Key3 = "<NameKana>"
Const Key4 = "</NameKana>"
Const PutBokName = "M.xlsx"
Dim buf As String
Dim Len1 As Long
Dim Len2 As Long
Dim Pos1 As Long
Dim Pos2 As Long
Dim Len3 As Long
Dim Len4 As Long
Dim Pos3 As Long
Dim Pos4 As Long
Dim PutBook As Workbook
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile MyFile
buf = .ReadText
.Close
End With
Len1 = Len(Key1)
Len2 = Len(Key2)
Pos1 = InStr(buf, Key1)
Pos2 = InStr(buf, Key2)
Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)
Set PutBook = Workbooks.Add
With PutBook.Sheets(1)
.Cells(1, 1).Value = "氏名"
.Cells(1, 2).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))
.Cells(2, 1).Value = "氏名カナ"
.Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3))
'クリップボードをクリア
Application.CutCopyMode = False
PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName
End With
Const PutBokName = "R.xlsx"
Dim buf As String
Dim Len1 As Long
Dim Len2 As Long
Dim Pos1 As Long
Dim Pos2 As Long
Dim Len3 As Long
Dim Len4 As Long
Dim Pos3 As Long
Dim Pos4 As Long
Dim PutBook As Workbook
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile MyFile
buf = .ReadText
.Close
End With
Len1 = Len(Key1)
Len2 = Len(Key2)
Pos1 = InStr(buf, Key1)
Pos2 = InStr(buf, Key2)
Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)
Set PutBook = Workbooks.Add
With PutBook.Sheets(1)
.Cells(1, 1).Value = "氏名"
.Cells(2, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))
.Cells(1, 2).Value = "氏名カナ"
.Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3))
'クリップボードをクリア
Application.CutCopyMode = False
PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName
End With
End Sub
-------------------------------
あるxmlファイルを一旦テキストファイルにして
そこから数値をエクセルファイルに移行して
ひとつはM.xlsxとし
それに続いて行列を入れ替えた
エクセルファイルR.xlsxを
作りたいのですが
M.xlsx R.xlsxのそれぞれを作るコードを
単純に 合体させただけでは
どうも できません
M.xlsxだけ また R.xlsxだけの
作成するコードは 出来たのですが
それぞれ別のマクロとして実行することになります
ひとつのマクロでM.xlsx R.xlsx同時に
作成するVBAコードは可能でしょうか
宜しくお願い致します
ちなみに該当コードを単純化して
合体したのが以下のものです
win10 office10
Sub 783縦()
Dim FileName As Variant
ChDir "\\DESKTOP-O5\f"
FileName = Application.GetOpenFilename(FileFilter:="xmlファイル,*.xml")
If FileName = False Then
MsgBox "キャンセルされました"
Exit Sub
End If
FileCopy FileName, Left(FileName, InStrRev(FileName, "\")) & "テキスト.txt"
Const MyFile = "\\DESKTOP-O5\f\テキスト.txt"
Const Key1 = "<Name>"
Const Key2 = "</Name>"
Const Key3 = "<NameKana>"
Const Key4 = "</NameKana>"
Const PutBokName = "M.xlsx"
Dim buf As String
Dim Len1 As Long
Dim Len2 As Long
Dim Pos1 As Long
Dim Pos2 As Long
Dim Len3 As Long
Dim Len4 As Long
Dim Pos3 As Long
Dim Pos4 As Long
Dim PutBook As Workbook
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile MyFile
buf = .ReadText
.Close
End With
Len1 = Len(Key1)
Len2 = Len(Key2)
Pos1 = InStr(buf, Key1)
Pos2 = InStr(buf, Key2)
Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)
Set PutBook = Workbooks.Add
With PutBook.Sheets(1)
.Cells(1, 1).Value = "氏名"
.Cells(1, 2).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))
.Cells(2, 1).Value = "氏名カナ"
.Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3))
'クリップボードをクリア
Application.CutCopyMode = False
PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName
End With
Const PutBokName = "R.xlsx"
Dim buf As String
Dim Len1 As Long
Dim Len2 As Long
Dim Pos1 As Long
Dim Pos2 As Long
Dim Len3 As Long
Dim Len4 As Long
Dim Pos3 As Long
Dim Pos4 As Long
Dim PutBook As Workbook
With CreateObject("ADODB.Stream")
.Charset = "UTF-8"
.Open
.LoadFromFile MyFile
buf = .ReadText
.Close
End With
Len1 = Len(Key1)
Len2 = Len(Key2)
Pos1 = InStr(buf, Key1)
Pos2 = InStr(buf, Key2)
Len3 = Len(Key3)
Len4 = Len(Key4)
Pos3 = InStr(buf, Key3)
Pos4 = InStr(buf, Key4)
Set PutBook = Workbooks.Add
With PutBook.Sheets(1)
.Cells(1, 1).Value = "氏名"
.Cells(2, 1).Value = Mid(buf, Pos1 + Len1, Pos2 - (Pos1 + Len1))
.Cells(1, 2).Value = "氏名カナ"
.Cells(2, 2).Value = Mid(buf, Pos3 + Len3, Pos4 - (Pos3 + Len3))
'クリップボードをクリア
Application.CutCopyMode = False
PutBook.SaveAs ThisWorkbook.Path & "\" & PutBokName
End With
End Sub
-------------------------------
