Excel VBA質問箱 IV

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

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

  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2482 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
▼ 【67726】パスワードが設定された複数ブック内のデータを一括してコピー貼り付けする ケメ子 11/1/4(火) 22:04 質問[未読]
【67728】Re:パスワードが設定された複数ブック内の... ｍｏｍｏ 11/1/5(水) 13:45 発言[未読]
【67729】Re:パスワードが設定された複数ブック内の... UO3 11/1/5(水) 18:26 回答[未読]
【67733】Re:パスワードが設定された複数ブック内の... ケメ子 11/1/5(水) 22:17 質問[未読]
【67734】Re:パスワードが設定された複数ブック内の... UO3 11/1/5(水) 22:23 発言[未読]
【67735】Re:パスワードが設定された複数ブック内の... ケメ子 11/1/5(水) 23:21 回答[未読]
【67738】Re:パスワードが設定された複数ブック内の... UO3 11/1/6(木) 10:43 回答[未読]
【67759】Re:パスワードが設定された複数ブック内の... ケメ子 11/1/6(木) 19:57 質問[未読]
【67760】原因がわかりました ケメ子 11/1/6(木) 21:28 質問[未読]
【67765】Re:原因がわかりました UO3 11/1/7(金) 6:47 回答[未読]
【67768】Re:原因がわかりました UO3 11/1/7(金) 9:17 回答[未読]
【67780】Re:原因がわかりました ケメ子 11/1/7(金) 21:39 発言[未読]
【67781】Re:原因がわかりました UO3 11/1/7(金) 22:33 回答[未読]
【67783】Re:原因がわかりました ケメ子 11/1/7(金) 23:31 お礼[未読]
【67726】パスワードが設定された複数ブック内のデ...
質問  ケメ子  - 11/1/4(火) 22:04 -
引用なし
パスワード
   同じ読み取りパスワードが設定されたファイルに一括して、他のブックからのデータをコピー貼り付けしたく、質問させていただきます。

＜貼り付けるデータが入っているブックについて＞
元1.xls〜元20.xlsという貼り付けるデータが入っているブックが20あるとします。
こちらには、パスワードは設定されていません。

この元1〜20のブックには、それぞれシートがA,B,C,Dと、どのブックにも同じように4枚のシートがあります。
こちらの各同じ範囲（ここでは統一してA1〜A50としておきます）を、貼り付け先ブックに貼り付けたいと思っております。

＜貼り付け先のブックについて＞

貼り付け先のブックも同じく20個あり、先1〜先20.xlsという名前で用意されており、シートがA,B,C,Dと4枚あります。
この20個のブックには共通した読み取りパスワード「abc」が設定されているとします。

やりたいことは、「元」ブックの指定した範囲（A1〜A50）を、元ブック番号と対応した「先」ブックのA,B,C,Dシートの各G5セルを先頭にして貼り付ける、というものです。

イメージは、

　元1.xls---シートA（A1〜A50）--->　先1.xls---シートA（G5〜）
　元1.xls---シートB（A1〜A50）--->　先1.xls---シートB（G5〜）
　　　　　　：　　　　　　　　　　　　　　　　：
　という感じです。

●ポイント

貼り付け先ブックにはパスワードが設定されているため、いちいちパスワードを入力しながら開いてコピー貼り付けするのは面倒。
そのため、マクロ専用のブックを別に作って、そこから貼り付け先ブック20個を自動的に開き、指定した範囲がコピーされるように遠隔操作したい。

と思っております。
マクロ専用のブックには、コマンドボタンを作成する、または、ファイル名の一覧を作成する、などの方法もあると思いますが、一番効率のよい方法などをご教示いただけると幸いです。

よろしくお願いいたします。
【67728】Re:パスワードが設定された複数ブック内...
発言  ｍｏｍｏ  - 11/1/5(水) 13:45 -
引用なし
パスワード
   ▼ケメ子 さん：
こんにちは

>一番効率のよい方法などをご教示いただけると幸いです。

効率の良さはわかりませんが、一般的なサンプルを載せてみます
単純に開いてコピペして保存する。を繰り返すコードです。

　Sub test()
　Const myPath As String = "D:\test\"
　Dim i As Long
　Dim shName As Variant
　Dim wbA As Workbook, wbB As Workbook
　Application.ScreenUpdating = False
　For i = 1 To 20
　　Set wbA = Workbooks.Open(myPath & "元" & i & ".xls")
　　Set wbB = Workbooks.Open(myPath & "先" & i & ".xls", Password:="abc")
　　For Each shName In Array("A", "B", "C", "D")
　　　wbA.Worksheets(shName).Range("A1:A50").Copy _
　　　　wbB.Worksheets(shName).Range("G5")
　　Next shName
　　wbA.Close False
　　wbB.Close True
　Next i
　Application.ScreenUpdating = True
　End Sub
【67729】Re:パスワードが設定された複数ブック内...
回答  UO3  - 11/1/5(水) 18:26 -
引用なし
パスワード
   ▼ケメ子 さん：

こんにちは

元ブックを開かないで処理を行う案です。
かんたんなテストしかしていないのでバグあればご容赦。

Sub Sample()
　　Dim fPath As String　 '元ブックのパス
　　Dim tPath As String　 '先ブックのパス
　　Dim fPre As String　　'元ブックの統一名
　　Dim tPre As String　　'先ブックの統一名
　　Dim i As Long
　　Dim shn As Variant
　　
　　Application.ScreenUpdating = False
　　
　　fPath = "c:\Test1\"　 '実際の名前に
　　tPath = "c:\Test2\"　 '実際の名前に
　　fPre = "元"
　　tPre = "先"
　　
　　For i = 1 To 20
　　　　Workbooks.Open tPath & tPre & i & ".xls", Password:="abc"
　　　　For Each shn In Array("A", "B", "C", "D")
　　　　　　With Worksheets(shn).Range("G5").Resize(50)
　　　　　　　　.Formula = "='" & fPath & "[" & fPre & i & ".xls]" & shn & "'!A1"
　　　　　　　　.Value = .Value
　　　　　　End With
　　　　Next
　　　　ActiveWorkbook.Close True
　　Next
　　
　　Application.ScreenUpdating = True
　　
　　MsgBox "処理が終了しました。"
　　
End Sub
【67733】Re:パスワードが設定された複数ブック内...
質問  ケメ子  - 11/1/5(水) 22:17 -
引用なし
パスワード
   momoさま　UO3 さま

このたびは、本当にありがとうございました。
大変申し訳ないことに、実際のブック名は少し異なっており、以下の通りです。

＜貼り付け元のデータが入っているブック＞

【作業】200706041_●●●（顧客名A）
というように、「【作業】」の次に9ケタの番号、顧客名と続いています。

「【作業】」というのは貼り付け元のブックのみ入っており、9ケタの番号は、何の関連性もなく入っておりますが、同じ番号はありません。
このようなブックが20くらいありますが、数は状況に応じて変動します。

この9ケタの番号と同じ番号、顧客名が入っているのが、＜貼り付け先ブック＞になります。


＜貼り付け先ブック＞

200706041_●●●　というように、9ケタの番号が先頭にあり、先ほどの＜貼り付け元データの入ったブック＞の番号と同じになっています。
そして、このブックも同じく20くらいある時もあれば、変動する場合もあります。
★ 貼り付け先のブックはすべて「読み取りパスワード（例：abc）」が設定されています。

それぞれのブックでは、前の投稿で書いたように、同じシート名が4つずつ（例：A、B、C、D）用意されております。

この状態でやりたいことは、

1.同じ番号同士の貼り付け元ブックから、パスワード付きの貼り付け先ブックにコピー貼り付けする。
2.その際、それぞれ同じ名前のシートからコピー貼り付けする。
3.貼り付け元のデータ範囲（【作業】〜から始まるブック）は、G6から下方向（変動）、貼り付け先の先頭位置は

シートA→P5から
シートB→O5から
シートC→V5から
シートD→N5から

というように、それぞれ位置が変わります。

このような場合、For〜Nextは使えるのでしょうか。
それとも、ファイルの一覧を一旦表示させた方がいいのかどうか、教えていただけると幸いです。

煮詰まってしまい、本当に申し訳ありませんがどうぞよろしくお願いいたします。。
個所に貼り付けたい」というのが本当の目的になります。
【67734】Re:パスワードが設定された複数ブック内...
発言  UO3  - 11/1/5(水) 22:23 -
引用なし
パスワード
   ▼ケメ子 さん：

こんばんは

提示されたブック名が【仮の名前】ということは、想像していました。
新たに出された要件も、【ぎょっとするようなもの】ではありませんので
コード修正は容易だと思われますが、その前に、

対象のブックですが

・たとえば、どこかのフォルダに入っているブックのすべて
・あるいは、その中のブックで、頭に【作業】とついているものすべて

このいずれかであれば、ブックが増減しても、ブック名を決めうちせず
処理できますが、いかがでしょうか。
【67735】Re:パスワードが設定された複数ブック内...
回答  ケメ子  - 11/1/5(水) 23:21 -
引用なし
パスワード
   UO3 さま

お世話になっております。
ご返信ありがとうございます。

>提示されたブック名が【仮の名前】ということは、想像していました。
>新たに出された要件も、【ぎょっとするようなもの】ではありませんので
>コード修正は容易だと思われます

も、申し訳ございません・・・

>・たとえば、どこかのフォルダに入っているブックのすべて
>・あるいは、その中のブックで、頭に【作業】とついているものすべて

ありがとうございます。
＜貼り付け元＞の方は、仮ですが、Aサーバーの\作業用\2010年12月期フォルダ内の頭に【作業】が入っているものすべて、
＜貼り付け先＞の方は、
Bサーバーの\提出用\2010年12月期フォルダ内のブックすべてになります。

こんな分かりにくい説明で申し訳ございません…。
しかし、このようなブック名やフォルダ構造なのに、コードがすぐ浮かぶUO3さまはスゴすぎます…。

どうぞよろしくお願いいたします。
【67738】Re:パスワードが設定された複数ブック内...
回答  UO3  - 11/1/6(木) 10:43 -
引用なし
パスワード
   ▼ケメ子 さん：

こんにちは

サーバーのパス名を適切なものに変更した上でお試しください。
元ブック側のG6からの行数が変動するわけで、残念ながら、元ブックも開きます。

Sub Sample2()
　　Dim fPath As String　 '元ブックのサーバパス
　　Dim tPath As String　 '先ブックのサーバパス
　　Dim z As Long
　　Dim shn As Variant
　　Dim myFso As Object
　　Dim myFiles As Object
　　Dim myFile As Object
　　Dim tCell As String
　　Dim fName As String
　　Dim fBook As Workbook
　　Dim tBook As Workbook
　　
　　Application.ScreenUpdating = False
　　Set myFso = CreateObject("Scripting.FileSystemObject")
　　
　　fPath = "c:\Test1"　　'実際のサーバパス名に
　　tPath = "c:\Test2"　　'実際のサーバパス名に
　　
　　For Each myFile In myFso.GetFolder(tPath).Files
　　　　fName = "【作業】" & myFile.Name
　　　　If LCase(myFso.GetExtensionName(myFile.Name)) = "xls" And _
　　　　　　　　　　　　　　myFso.FileExists(fPath & "\" & fName) Then
　　　　　　Set fBook = Workbooks.Open(fPath & "\" & fName)
　　　　　　Set tBook = Workbooks.Open(tPath & "\" & myFile.Name, Password:="abc")
　　　　　　For Each shn In Array("A", "B", "C", "D")
　　　　　　
　　　　　　　　Select Case shn
　　　　　　　　　　Case "A"
　　　　　　　　　　　　tCell = "P5"
　　　　　　　　　　Case "B"
　　　　　　　　　　　　tCell = "C5"
　　　　　　　　　　Case "C"
　　　　　　　　　　　　tCell = "V5"
　　　　　　　　　　Case "D"
　　　　　　　　　　　　tCell = "N5"
　　　　　　　　End Select
　　　　　　　　
　　　　　　　　z = fBook.Sheets(shn).Range("G6").End(xlDown).Row - 5
　　　　　　　　tBook.Sheets(shn).Range(tCell).Resize(z).Value = _
　　　　　　　　　　　　　　fBook.Sheets(shn).Range("G6").Resize(z).Value
　　　　　　　　　　　　　　
　　　　　　Next
　　　　　　
　　　　　　tBook.Close True
　　　　　　fBook.Close False
　　　　　　
　　　　End If
　　Next
　　
　　Set myFso = Nothing
　　Set fBook = Nothing
　　Set tBook = Nothing
　　Application.ScreenUpdating = True
　　
　　MsgBox "処理が終了しました。"
　　
End Sub
【67759】Re:パスワードが設定された複数ブック内...
質問  ケメ子  - 11/1/6(木) 19:57 -
引用なし
パスワード
   UO3 さま

このたびは、本当にありがとうございます。。
ほぼ完成しつつあるのですが・・・

実行すると、　　　　　　
>　　　　　　　　z = fBook.Sheets(shn).Range("G6").End(xlDown).Row - 5
>　　　　　　　　tBook.Sheets(shn).Range(tCell).Resize(z).Value = _
>　　　　　　　　　　　　　　fBook.Sheets(shn).Range("G6").Resize(z).Value

の部分がエラーになって、黄色くなってしまいます。
その次が、元と先のブックを閉じる操作なのですが、貼り付け先ブックを見てみると、きちんと貼り付けられているようでした！！

なぜこちらがエラーになるのでしょうか？
このエラーさえ解決されれば、ブックが閉じられて作業が終了した旨のメッセージが出るんですよね・・・

見たところ入力間違いはなさそうです。
よろしければ、もう一度教えていただけますでしょうか？

何度も申し訳ございませんが、どうぞよろしくお願いいたします。
【67760】原因がわかりました
質問  ケメ子  - 11/1/6(木) 21:28 -
引用なし
パスワード
   UO3 さま

たびたび申し訳ございません。
さきほど投稿した

>　　　　　　　　tBook.Sheets(shn).Range(tCell).Resize(z).Value = _
>　　　　　　　　　　　　　　fBook.Sheets(shn).Range("G6").Resize(z).Value

でエラーが表示される件ですが、原因がわかりました。
どうも、元ブックで、G列に何もデータがないシートがあると、エラーが起こるようです。

たとえば、元の”C”シートのG6から下方向は何も入っていない、というようなときに起こるようです。
こちらを防ぐにはどうしたらよろしいか、お伺いできますでしょうか。

たびたび申し訳ございません・・・
【67765】Re:原因がわかりました
回答  UO3  - 11/1/7(金) 6:47 -
引用なし
パスワード
   ▼ケメ子 さん：

おはようございます。
以下のようにしてお試しください。

z = fBook.Sheets(shn).Range("G6").End(xlDown).Row - 5
If z >= 6 Then
　　tBook.Sheets(shn).Range(tCell).Resize(z).Value = _
　　　　　　　　fBook.Sheets(shn).Range("G6").Resize(z).Value
End If
【67768】Re:原因がわかりました
回答  UO3  - 11/1/7(金) 9:17 -
引用なし
パスワード
   ▼ケメ子 さん：

追加です。
もし、いったん先ブックに反映させた後、なんらかの理由で元ブックを変更し
あらためて先ブックに反映させるケースがあるとして、この時、元ブック側の
行数が減少していると、元ブックにある行数のみ転記する結果、先ブックに
前回転記されたものが、残ってしまう可能性がありますね。

このようなケースがありえ、それを回避するということなら、上で連絡した
転記データ有無のチェックも加味すると、以下のようなコードに。

Sub Sample3()
　　Dim fPath As String　 '元ブックのサーバパス
　　Dim tPath As String　 '先ブックのサーバパス
　　Dim z As Long
　　Dim shn As Variant
　　Dim myFso As Object
　　Dim myFiles As Object
　　Dim myFile As Object
　　Dim tCell As String
　　Dim fName As String
　　Dim fBook As Workbook
　　Dim tBook As Workbook
　
　　Application.ScreenUpdating = False
　　Set myFso = CreateObject("Scripting.FileSystemObject")
　
　　fPath = "c:\Test1"　　'実際のサーバパス名に
　　tPath = "c:\Test2"　　'実際のサーバパス名に
　
　　For Each myFile In myFso.GetFolder(tPath).Files
　　　　fName = "【作業】" & myFile.Name
　　　　If LCase(myFso.GetExtensionName(myFile.Name)) = "xls" And _
　　　　　　　　　　　　　　myFso.FileExists(fPath & "\" & fName) Then
　　　　　　Set fBook = Workbooks.Open(fPath & "\" & fName)
　　　　　　Set tBook = Workbooks.Open(tPath & "\" & myFile.Name, Password:="abc")
　　　　　　For Each shn In Array("A", "B", "C", "D")
　　　
　　　　　　　　Select Case shn
　　　　　　　　　　Case "A"
　　　　　　　　　　　　tCell = "P5"
　　　　　　　　　　Case "B"
　　　　　　　　　　　　tCell = "C5"
　　　　　　　　　　Case "C"
　　　　　　　　　　　　tCell = "V5"
　　　　　　　　　　Case "D"
　　　　　　　　　　　　tCell = "N5"
　　　　　　　　End Select
　　　　　　　　With tBook.Worksheets(shn)
　　　　　　　　　　.Range(tCell & ":" & Split(.Range(tCell).Address, "$")(1) & .Rows.Count).ClearContents
　　　　　　　　　　z = fBook.Sheets(shn).Range("G6").End(xlDown).Row - 5
　　　　　　　　　　If z >= 6 Then
　　　　　　　　　　　　.Range(tCell).Resize(z).Value = _
　　　　　　　　　　　　　　　　　　fBook.Sheets(shn).Range("G6").Resize(z).Value
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　Next
　　　
　　　　　　tBook.Close True
　　　　　　fBook.Close False
　　　
　　　　End If
　　Next
　
　　Set myFso = Nothing
　　Set fBook = Nothing
　　Set tBook = Nothing
　　Application.ScreenUpdating = True
　
　　MsgBox "処理が終了しました。"
　
End Sub
【67780】Re:原因がわかりました
発言  ケメ子  - 11/1/7(金) 21:39 -
引用なし
パスワード
   UO3さま

ほんとにほんとにありがとうございます・・・。
しかも

>もし、いったん先ブックに反映させた後、なんらかの理由で元ブックを変更し
>あらためて先ブックに反映させるケースがあるとして、この時、元ブック側の
>行数が減少していると、元ブックにある行数のみ転記する結果、先ブックに
>前回転記されたものが、残ってしまう可能性がありますね。

まったくその通りです。
恐れ入ります。

ですが、残念ながら、やはり同じ個所でエラーが出てしまうようです。。。
>　　　　　　　　　　If z >= 6 Then
の下の
>　　　　　　　　　　　　.Range(tCell).Resize(z).Value = _
>　　　　　　　　　　　　　　　　　　fBook.Sheets(shn).Range("G6").Resize(z).Value

の箇所です。
試しているファイルでは、作業元の"C"と"D"のシートで、該当する列のデータは、まったく入っておりません。

何度も申し訳ございません・・・
よろしくお願いいたします。
【67781】Re:原因がわかりました
回答  UO3  - 11/1/7(金) 22:33 -
引用なし
パスワード
   ▼ケメ子 さん：

ごめんなさい
単純なミスでした。
行数把握をxlUpでやっていたつもりでしたが、実際のコードはxlDown。
xlUpベースに直しました。

Option Explicit

Sub Sample3()
　　Dim fPath As String　 '元ブックのサーバパス
　　Dim tPath As String　 '先ブックのサーバパス
　　Dim z As Long
　　Dim shn As Variant
　　Dim myFso As Object
　　Dim myFiles As Object
　　Dim myFile As Object
　　Dim tCell As String
　　Dim fName As String
　　Dim fBook As Workbook
　　Dim tBook As Workbook
　　Dim xlRowMax As Long
　　
　　Application.ScreenUpdating = False
　　Set myFso = CreateObject("Scripting.FileSystemObject")

　　fPath = "c:\Test1"　　'実際のサーバパス名に
　　tPath = "c:\Test2"　　'実際のサーバパス名に
　　xlRowMax = Rows.Count
　　
　　For Each myFile In myFso.GetFolder(tPath).Files
　　　　fName = "【作業】" & myFile.Name
　　　　If LCase(myFso.GetExtensionName(myFile.Name)) = "xls" And _
　　　　　　　　　　　　　　myFso.FileExists(fPath & "\" & fName) Then
　　　　　　Set fBook = Workbooks.Open(fPath & "\" & fName)
　　　　　　Set tBook = Workbooks.Open(tPath & "\" & myFile.Name, Password:="abc")
　　　　　　For Each shn In Array("A", "B", "C", "D")
　
　　　　　　　　Select Case shn
　　　　　　　　　　Case "A"
　　　　　　　　　　　　tCell = "P5"
　　　　　　　　　　Case "B"
　　　　　　　　　　　　tCell = "C5"
　　　　　　　　　　Case "C"
　　　　　　　　　　　　tCell = "V5"
　　　　　　　　　　Case "D"
　　　　　　　　　　　　tCell = "N5"
　　　　　　　　End Select
　　　　　　　　With tBook.Worksheets(shn)
　　　　　　　　　　.Range(tCell & ":" & Split(.Range(tCell).Address, "$")(1) & xlRowMax).ClearContents
　　　　　　　　　　z = fBook.Sheets(shn).Range("G" & xlRowMax).End(xlUp).Row
　　　　　　　　　　If z >= 6 Then
　　　　　　　　　　　　.Range(tCell).Resize(z - 5).Value = _
　　　　　　　　　　　　　　　　　　fBook.Sheets(shn).Range("G6").Resize(z - 5).Value
　　　　　　　　　　End If
　　　　　　　　End With
　　　　　　Next
　
　　　　　　tBook.Close True
　　　　　　fBook.Close False
　
　　　　End If
　　Next

　　Set myFso = Nothing
　　Set fBook = Nothing
　　Set tBook = Nothing
　　Application.ScreenUpdating = True

　　MsgBox "処理が終了しました。"
【67783】Re:原因がわかりました
お礼  ケメ子  - 11/1/7(金) 23:31 -
引用なし
パスワード
   UO3さま

ありがとうございます、ありがとうございます；；
完璧です！！！！！！
なんとお礼を言ったらよいか…。

どうしたらこんな素晴らしい考え方ができるのでしょうか…
本当に感謝いたします。。

いろいろ勉強させていただきましたが、今後も是非ご教示いただければ幸いです。
これからもどうぞよろしくお願いいたします。
  新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム  
2482 / 13646 ﾂﾘｰ ←次へ　｜　前へ→
ページ：  ┃  記事番号：
2610219
(SS)C-BOARD v3.8 is Free