他のブックから特定のシートを自ブックに取り込みたいのですが

質問

目的は月末に提出される従業員からの当月月報を簡便に集計する事前準備で、内容は、従業員が提出する月報.xlsの集積フォルダ「月報管理」に保存された複数の月報.xlsを個々に開き、就業時間が記載された対象sheetを予め作成した自ブック「月報管理.xls」にそれぞれコピーし、個々に開かれた月報.xlsを一括して閉じるまでの作業をマクロ化出来ないかということです。
初心者のため、こちらのようなサイトを多々巡り、途中までは必要部位を真似て作成したのですが、選択したシートを自ブックにコピーする段階で先に進めなくなりました。
恐れ入りますが、何方様かご教授いただけませんでしょうか？

また、同様の作業を更に簡便なマクロに置き換えらても構いませんので、何卒、宜しくお願い致します。

参考までに、従業員が提出する月報は作成する際のマクロによってファイル名とsheet名を同一にしております。

例）
Aさん＊月分.xls 内に Aさん＊月分sheet含む
Bさん＊月分.xls 内に Bさん＊月分sheet含む
Cさん＊月分.xls 内に Cさん＊月分sheet含む

↓　自ブックに設定したマクロです　↓

Private Sub CommandButton1_Click()

'１，ファイル名の取得

Dim myFolder As String 'ドライブ、フォルダ
Dim filename As String 'ファイル名

myFolder = "C:\Documents and Settings\nobita\デスクトップ\月報集計"
filename = Dir(myFolder & "\" & "*.xls")
Do While filename <> ""
filename = Dir()
Loop

'２，フォルダ内「月分」が含まれるファイルを開く

Dim i As Integer
With Application.FileSearch

.NewSearch
.LookIn = myFolder
.filename = "*月分*.xls"
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
For i = 1 To .FoundFiles.Count
Workbooks.Open filename:=.FoundFiles(i)
Next
Else
MsgBox ("該当ファイルが見つかりません。")
End If
End With

'３，開いたファイル内の共通対象シート(*月分*)を選択

Dim myWS As Worksheet
For Each myWS In Worksheets
If myWS.Name Like "*月分*" Then
　 If ActiveSheet.Name Like "*月分*" Then
myWS.Select (False)
Else
myWS.Select
End If
End If
Next

'４，３で選択されたシートを自ブックにコピー

'５，２で開いたファイルを閉じる

End Sub

回答No.2

hige_082 · ベストアンサー

根本的に構文が間違っていました、すみません
他にも不具合があったので修正してみました

Private Sub CommandButton1_Click()
'１，ファイル名の取得
Dim myFolder As String 'ドライブ、フォルダ
Dim filename As String 'ファイル名
Dim myfile As String 'ファイル名
Dim myWS As Worksheet
Dim 自ブック As Workbook
Dim 開いたブック As Workbook
Set 自ブック = ActiveWorkbook
myFolder = "C:\Documents and Settings\nobita\デスクトップ\月報集計"
filename = Dir(myFolder & "\" & "*月分*.xls")
If filename = "" Then Exit Sub
myfile = filename
Do
Workbooks.Open filename:=myFolder & "\" & myfile
Set 開いたブック = Workbooks(myfile)
For Each myWS In 開いたブック.Worksheets
If myWS.Name Like "*月分*" Then
'４，３で選択されたシートを自ブックにコピー
myWS.Copy After:=自ブック.Sheets(自ブック.Sheets.Count)
End If
Next
'５，２で開いたファイルを閉じる
開いたブック.Close SaveChanges:=False
myfile = Dir()
Loop Until myfile = filename Or myfile = ""
End Sub

参考まで

お礼

hige_082　様

ご教授いただきました修正版で望み通りの動作が得られました。
何日も悩み、解決できなかったことなので大変、助かりました。
また、事前準備の効率が格段に上がりました。
ありがとうございました。

ついでになってしまい、申し訳ないのですが、取り込みの終わった各シートから
必要な数値を別シートに抜き取り、処理を終えた時点で取り込んだ「*月分」を含む
シートのみを自ブックから消去したいのですが、ご教授いただけますでしょうか？
動作の制御は新たな　CommandButton2　を作成して行うつもりです。

お手数ですが何卒、宜しくお願い致します。

回答No.3

hige_082

＃２の補足読みました
最初の質問と違う内容の質問になる場合は
一度閉じて再質問してくださいね

Sub test()
Dim st As Worksheet
Application.DisplayAlerts = False
For Each st In Worksheets
If InStr(st.Name, "月分") > 0 Then
st.Delete
End If
Next
Application.DisplayAlerts = True
End Sub

このマクロに関して補足等がある場合は再質問でお願いします

お礼

＞＃２の補足読みました
＞最初の質問と違う内容の質問になる場合は
＞一度閉じて再質問してくださいね

大変申し訳ございませんでした。
一度、質問を終了し、新たに質問をするよう気をつけます。

また、懇切丁寧なご回答を毎々、有難うございました。

回答No.1

hige_082

こんな感じでは？
試してないので、エラー出るかも

Private Sub CommandButton1_Click()
'１，ファイル名の取得
Dim myFolder As String 'ドライブ、フォルダ
Dim filename As String 'ファイル名
Dim myfile As String 'ファイル名
Dim myWS As Worksheet
Dim 自ブック As Workbook
Dim 開いたブック As Workbook
Set 自ブック = ActiveWorkbook
myFolder = "C:\Documents and Settings\nobita\デスクトップ\月報集計"
filename = Dir(myFolder & "\" & "*月分*.xls")
If filename = "" Then Exit Sub
myfile = filename
Do
Workbooks.Open filename:=myFolder & "\" & myfile
Set 開いたブック = ActiveWorkbook
For Each myWS In 開いたブック.Worksheets
If myWS.Name Like "*月分*" Then
'４，３で選択されたシートを自ブックにコピー
myWS.Copy After:=自ブック.Sheets.Count
'５，２で開いたファイルを閉じる
開いたブック.Close SaveChanges:=False
End If
Next
myfile = Dir()
Loop Until myfile = filename
End Sub

参考まで

補足

hige_082　様

早急なご回答有難うございました。
早速、実行致しましたが、実行時エラー'1004':　'copy'メソッドは失敗しましたとエラーになりました。

'選択されたシートを自ブックにコピー
myWS.Copy After:=自ブック.Sheets.Count　←　この部分が黄色くなっておりました。