特定のフォルダからエクセルブックのみを抽出し別のフォルダに集める（コピーする）マクロを作りたいと思い、以下のように作成しました。
（AAAフォルダ⇒移動元、BBBフォルダ⇒移動先）
ただしこれだと、AAAフォルダ内にあるサブフォルダからは拾ってこれないようです。
AAA内の全てのサブフォルダからエクセルブックを拾ってくるにはどう修正すればよろしいでしょうか。
―――――――――――
Sub sample1()
Dim FSO As Object, fld As Variant, bk As Variant
Const Fld1 As String = "C:\AAA"
Const Fld2 As String = "C:\BBB\"
Const tgt As String = "*.xlsx"
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each fld In FSO.GetFolder(Fld1).SubFolders
For Each bk In fld.Files
If bk.Name Like tgt Then
bk.Copy Fld2
End If
Next bk
Next fld
End Sub
宜しくお願いします。
OS:Windows10 pro
Office:MS Office 2010 Pro Plus
Excelを使用中、AccessのA1というデータベースを参照したい場合があります。
このA1というデータベースのショートカットをEXCELのクイックアクセスツールバーに表示させることは可能でしょうか。
特定のフォルダからエクセルブックのみを抽出し別のフォルダに集める（コピーする）マクロを作りたいと思い、以下のように作成しました。
（AAAフォルダ⇒移動元、BBBフォルダ⇒移動先）
ただしこれだと、AAAフォルダ内にあるサブフォルダからは拾ってこれないようです。
AAA内の全てのサブフォルダからエクセルブックを拾ってくるにはどう修正すればよろしいでしょうか。
―――――――――――
Sub sample1()
Dim FSO As Object, fld As Variant, bk As Variant
Const Fld1 As String = "C:\AAA"
Const Fld2 As String = "C:\BBB\"
Const tgt As String = "*.xlsx"
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each fld In FSO.GetFolder(Fld1).SubFolders
For Each bk In fld.Files
If bk.Name Like tgt Then
bk.Copy Fld2
End If
Next bk
Next fld
End Sub
特定のフォルダからエクセルブックのみを抽出し別のフォルダに集める（コピーする）マクロを作りたいと思い、以下のように作成しました。
（AAAフォルダ⇒移動元、BBBフォルダ⇒移動先）
ただしこれだと、AAAフォルダ内にあるサブフォルダからは拾ってこれないようです。
AAA内の全てのサブフォルダからエクセルブックを拾ってくるにはどう修正すればよろしいでしょうか。
―――――――――――
Sub sample1()
Dim FSO As Object, fld As Variant, bk As Variant
Const Fld1 As String = "C:\AAA"
Const Fld2 As String = "C:\BBB\"
Const tgt As String = "*.xlsx"
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each fld In FSO.GetFolder(Fld1).SubFolders
For Each bk In fld.Files
If bk.Name Like tgt Then
bk.Copy Fld2
End If
Next bk
Next fld
End Sub
質問No.9060575で下記のような質問をさせて頂きました。
↓↓↓↓↓↓↓↓
ファイルを選択するマクロを教えてください。
ブックAのシートA セルA1に100という数字が入力されています。
C:\Users\Documents のフォルダの中に
シート選択#100.xlsm
シート選択#101.xlsm
シート選択#102.xlsm
シート選択#103.xlsm
シート選択#104.xlsm
というシートがあるとします。
やりたいことはセルA1に数字が入力されている状態でマクロ実行ボタンを押した時
C:\Users\Documentsのフォルダの中にあるシート選択#100.xlsmのシートを開きたいです。
セルA1が101ならシート選択#101.xlsmを開く。
またセルA1になにも入力されていない場合はメッセージで
[入力されていません]
入力されていてもフォルダ内に当てはまる番号がない場合は
[ヒットするNo.がありません]
みたいな感じでメッセージを表示したいです。
宜しくお願いします。
↑↑↑↑↑↑↑↑
この質問で回答をもらい、解決できましたが
ここにプラスαで、もしA2セルに999と入力されていて
C:\Users\Documents のフォルダの中に
シート選択#100#999.xlsm
というシートや
シート選択#101#995.xlsm
というシートがある場合はどのようにすればよろしいでしょうか？
前回と同じく100や999の部分はランダムに変わります。
前回のベストアンサーを載せておきます。
■VBAコード
Sub file_open()
Dim f_fmt As String, i As Integer
'設定==============
Const dpath As String = "C:\Users\Documents\"
Const adr As String = "A1"
Const st As String = "シートA"
f_fmt = "#<NO>\シート選択#<NO>.xlsm"
'==================
If Len(Range(adr).Value) = 0 Then MsgBox "入力されていません": Exit Sub
f_fmt = dpath & Replace(f_fmt, "<NO>", Range(adr).Value)
If Dir(f_fmt) = "" Then MsgBox "ヒットするNo.がありません": Exit Sub
Workbooks.Open Filename:=f_fmt
For i = 1 To Worksheets.Count
If Worksheets(i).Name = st Then
Worksheets(i).Activate
Exit Sub
End If
Next i
MsgBox "ワークブック """ & Dir(f_fmt) & """ に、ワークシート """ & st & """ が見つかりません"
End Sub
エクセル初心者です。
自分のユーザーフォーム（住所、商品登録）を作りたくて大変困ってます。
下記は、ネットなどをみて貼り付けたのですが、上手くいきません。
まずＴＯＰページを作り、ユーザーフォームを呼び出すボタンを作り、クリックすると
フォームが出るようにしてあります。
そこに、自分の入力したいものをユーザーフォームにテキストでつくり、シート９に
登録ボタンを作りクリックしたら、シートに反映させたいと思ってます。
登録ボタンを押したら、入力画面はクリアにしたいです。
他にいろいろやりたい事もあるのですが、入力した順番に001・002・003と顧客番号をつけたり
検索ボタンを作って、名前や、顧客番号を入れると情報を呼び出したり、請求書用のプリントシートや、封筒シートに簡単に反映できればと思っています。
しかし、まだまだそこまではいかず、最初でつまずいてます。
現状は、フォームを呼び出すときに実行時エラーがでます。
どうしても、自分の使い勝手のいいものを作りたいので
どうか、助けてください。大変まいってます。
長文になりますが、どうかよろしくお願いします。
下記の入力中のものをみていただけて、いろいろ意見をいただけるとありがたいです。
Sub FormShow()
UserForm1.Show
End Sub
'Sheet9へ書き込む
Private Sub 登録_Click()
Dim i As Integer
With Worksheets(9)
'テキストボックスの値を書き出し
For i = 1 To 80
.Range("B" & i) = UserForm1.Controls("TextBox" & i).Text
Next
End With
End Sub
'Formを呼び出したとき、Sheet9から読み込む
Private Sub UserForm_Initialize()
Dim i As Integer
With Worksheets(9)
'テキストボックスの値を読み込み
For i = 1 To 80
UserForm1.Controls("TextBox" & i).Text = .Range("B" & i)
Next
End With
End Sub
'終了ボタン
Private Sub CommandButton2_Click()
Unload Me
End Sub
