マクロ 任意の・・・を特定のシートへコピーする

質問

いつも回答して頂きありがとうございます。

質問内容ですが・・・
(1)任意のブックを開ける。今回は『C:\Users\Owner\Documents\作業管理.xlsm』
　 ※本当のファイル名は『作業管理２０１３年８月』みたいなものになる
９月なら『作業管理２０１３年９月』
(2)任意のシートをコピーする。今回は『１』
　 ※数字の意味は日付。
　　　ですが、今日の日付＝シート名になるとは限らない。ですので、任意で選択したい。
(3)特定のシートへ貼り付ける。
　 dim ws1 as object
set ws1 = activesheet
(4)・・・
という順序のマクロを考えていますが、任意のブックを開けて、任意のシートをコピーするという箇所の記述が分かりません。どのような記述方法があるのか教えて頂けないでしょうか？
宜しくお願い致します。

回答No.3

keithin · ベストアンサー

＞任意のブックを開けて、任意のシートをコピーする

考え方が（多分日本語が）間違ってます。
任意じゃなく、年月日の指定により該当するブック、シートは一義的に定まるのですよね。

手順の例：
マクロを起動する
年月日を入力させる
該当するブックを開く
該当するシートをコピーする(どこに？)。

sub macro1()
　dim myPath as string
　dim myFile as string
　dim myDate as date
　dim mySheet as string

　mypath = "C:\Users\Owner\Documents\"
　on error goto errhandle
　mydate = inputbox("yyyy/mm/dd")
　on error goto 0

　myfile = "作業管理" & strconv(format(mydate, "yyyy年m月"), vbwide) & ".xlsm"
　mysheet = strconv(day(mydate), vbwide)

　workbooks.open filename:=mypath & myfile
　workbooks(myfile).worksheets(mysheet).copy before:=thisworkbook.worksheets(1)
　workbooks(myfile).close savechanges:=false

　exit sub

errhandle:
　msgbox "BAD DATE"
end sub

年月の指定と日の指定を別建てにしたいのかもしれませんが、その辺は単なるバリエーション（応用）です。

お礼

いつも回答して下さりありがとうございます。
提示してくれた記述をちょこちょこっといじりました。で、質問ですが、ファイル名とかで使用している数字を半角でも全角でも認識出来るようにする事は可能なのでしょうか？

下記がちょこっと変えた記述です。エラーも無く動くのでいいのかなと思いますが、直した方が良い箇所ありますか？

Sub macro1()

Dim myPath1 As String
Dim myPath2 As String
Dim myFile As String
Dim myDate As Date
Dim mySheet As String

On Error GoTo errhandle
myDate = InputBox("yyyy/mm/dd")
On Error GoTo 0

myPath1 = "C:\Users\Owner\Documents\"
myPath2 = "C:\Users\Owner\Documents\" & Format(myDate, "yyyy年") & "\"
myFile = "作業管理" & Format(myDate, "yyyy年m月") & ".xlsx"
mySheet = Day(myDate)

If Dir(myPath1 & myFile) <> "" Then
Workbooks.Open Filename:=myPath1 & myFile
ElseIf Dir(myPath2 & myFile) <> "" Then
Workbooks.Open Filename:=myPath2 & myFile
Else
MsgBox (myFile & "が存在しません。")
Exit Sub
End If
Workbooks(myFile).Worksheets(mySheet).Copy before:=ThisWorkbook.Worksheets(1)
Workbooks(myFile).Close savechanges:=False
Exit Sub

errhandle:
MsgBox "BAD DATE"
End Sub

回答No.5

mt2008

ListBoxとCommandButtonを貼り付けたユーザフォームを作り、以下のコードを入れてみて下さい。
自ブックから　UserForm1.Show　で作ったユーザフォームを開くと（１）、（２）を行います（コピーできたことを確認するために自ブックの1枚目のシートに値貼り付けも行っています）。
なお、あくまでもサンプルですので、終了したり開いたブックを閉じたりする箇所は作っていません。あしからず。

Private Sub UserForm_Initialize()
　　'(1)任意のブックを開ける。-->ブックを指定して開く
　　Dim sOpenBook As String
　　sOpenBook = Application.GetOpenFilename("Excelブック,*.xlsm")
　　If sOpenBook = "False" Then Exit Sub
　　Workbooks.Open Filename:=sOpenBook　　

　　'(2)任意のシートをコピーする。-->その１、ListBoxにシート一覧を作成
　　Dim sh As Object
　　For Each sh In ActiveWorkbook.Worksheets
　　　　ListBox1.AddItem sh.Name
　　Next sh
End Sub

Private Sub CommandButton1_Click()
　　 '(2)任意のシートをコピーする。-->その２、選択したシートをコピー
　　If IsNull(ListBox1.Value) Then
　　　　MsgBox ("シート未選択")
　　　　Exit Sub
　　End If
　　Sheets(ListBox1.Value).Cells.Copy

　　'(3)に該当する箇所。
　　ThisWorkbook.Sheets(1).Range("A1").PasteSpecial Paste:=xlPasteValues
End Sub

お礼

色々考えて下さりありがとうございました。
No.3の方の例を使用して、上手くいきました。

回答No.4

MarcoRossiItaly

任意、任意、とたくさん出てくるのですが、質問者さんがおっしゃるところの任意とは、何ですか？「作業管理２０１３年９月.xlsm」を開くとか、（シート名が？）「１」というシートをコピーするというコードを書くだけなら簡単ですが、可変じゃなくても任意なんでしょうか？どういう意味で任意なんでしょうか？また、「特定のシート」と言いながら、お示しのコードはアクティブシートであり、アクティブであるという以上には特定されていないですね。どのようにしたいのでしょうか？

＞……○○のブックを開けて、△△のシートをコピーするという箇所の記述が分かりません。

分かりませんとのことですが、ご自分でお調べになった結果はどうだったのでしょうか？質問文に載っていないのですが。

仕方がないので、とりあえずのこちらの対応としては、「作業管理２０１３年９月.xlsm」という特定のブックを開き、「１」という名前を持っている特定のシートをコピーし、たまたまアクティブであるシートに貼り付けるというコードを載せておきます。

また、おっしゃっているアクティブシートというのは、コードを載せている ThisWorkbook でマクロ実行時にアクティブだったシートのことだと解釈しておきます。他のブックを開くとそちらがアクティブになってしまうことを考慮する必要があります。

当然のことですが、全角と半角を区別しないと、マクロが正しく動作しません。ブック名やシート名が怪しい場合は、確認してから実行してください。

汎用的なものにするには下のコードを拡張していけばいいと思いますが、任意が何を意味するのかによって、その拡張の仕方も全然変わってくるということを理解してください。

Sub GetOtherFileData()

　　Dim p As String, f As String, d As String
　　Dim s As Worksheet

　　p = "C:\Users\Owner\Documents\"
　　f = "作業管理２０１３年９月.xlsm"　　'開くブックを変更するには、手入力で一回一回コードを上書き修正するか、ファイル名の取得の方法を考える
　　d = "１"　　　　　　　　　　　　　　 'ファイル名と同様に方法を考える
　　Set s = ThisWorkbook.ActiveSheet　　 '貼り付け先が固定でないなら、他のファイルを開く前に変数に代入しておく

　　If Dir(p & f) = "" Then
　　　　MsgBox "対象ファイルが存在しないので、マクロを終了します"
　　　　Exit Sub
　　Else
　　　　Workbooks.Open p & f
　　　　Worksheets(d).Cells.Copy Destination:=s.Range("a1")
　　　　Workbooks(f).Close
　　End If

　　'ThisWorkbook.Save　　'必要に応じて先頭の「'」を削除

End Sub

お礼

色々考えて下さりありがとうございました。
No.3の方の例を使用して、上手くいきました。

回答No.2

kmetu

訂正です

OpenFileName = "作業管理" & Year(Date) & "年" & Month(Date, vbWide) & "月.xlsm"

↓

OpenFileName = "作業管理" & Year(Date) & "年" & Month(Date) & "月.xlsm"

お礼

ブックの名前に規則性があったので、提示した記述でブックの指定が出来たんですね。思いつきませんでした。ありがとうございました。

回答No.1

kmetu

任意のファイルを開く　ファイルを開くダイアログを開いて選択　という手でよろしければ以下のページを参考にしてください

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

> ９月なら『作業管理２０１３年９月』

このような決まりが必ずあるのでしたら

Dim OpenFileName As String
OpenFileName = "作業管理" & Year(Date) & "年" & Month(Date, vbWide) & "月.xlsm"
Workbooks.Open OpenFileName

年や月の数値が全角だと
"作業管理" & StrConv(Year(Date), vbWide) & "年" & StrConv(Month(Date), vbWide) & "月.xlsm"

シート名の任意選択は、フォームを作成してリストボックスかコンボボックスで選択する手でよろしければ以下のページを参考にしてください

http://www7b.biglobe.ne.jp/~whitetiger/ex/ex2002081.html

お礼

色々考えて下さりありがとうございました。
No.3の方の例を使用して、上手くいきました。