ここから本文です

前回6/28質問の(エクセルマクロで別ファイルへの貼り付け)はvcx000xcvさんの回答...

tom********さん

2017/7/107:17:30

前回6/28質問の(エクセルマクロで別ファイルへの貼り付け)はvcx000xcvさんの回答でバッチリOKでした。

このマクロを、貼り付け先ファイルの「要求表」に置いて「要求表」側から実行がうまく貼り付け出来ません。
分かる方、宜しくお願いします<(_ _)>


下記は元ファイル「要求シート」側からの内容です。(前回、vcx000xcvさんのから回答)

Sub Test()
Dim twb As Workbook, r As Range
Dim LRow As Long, tCol As Long

On Error GoTo ER:
Set twb = Workbooks("要求表.xlsx")

With ThisWorkbook.Worksheets(1)
tCol = 0
LRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For Each r In .Rows(2).Cells
If r.Value = Date Then
tCol = r.Column
Exit For
End If
Next r
If tCol > 0 Then
Set r = .Range(.Cells(3, 3), .Cells(LRow, 3)).SpecialCells(12)
Set r = Union(r, .Range(.Cells(3, tCol), .Cells(LRow, tCol)).SpecialCells(12))
r.Copy
twb.Worksheets(1).Range("C3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End With

With ThisWorkbook.Worksheets(2)
tCol = 0
LRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For Each r In .Rows(2).Cells
If r.Value = Date Then
tCol = r.Column
Exit For
End If
Next r
If tCol > 0 Then
Set r = .Range(.Cells(3, 3), .Cells(LRow, 3)).SpecialCells(12)
Set r = Union(r, .Range(.Cells(3, tCol), .Cells(LRow, tCol)).SpecialCells(12))
r.Copy
twb.Worksheets(1).Range("C23").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End With

Exit Sub

ER:
MsgBox Err.Description & vbCrLf & "処理を中止しました。", vbCritical, "異常終了"
End Sub

閲覧数:
32
回答数:
2
お礼:
100枚

違反報告

ベストアンサーに選ばれた回答

vcx********さん

2017/7/114:18:56

tomoki_y_1224さん

他の方からのアドバイスが既にありますが、対象となっているブックが2つで、それを表しているのが2つのキーワードです。

1つは twb
1つは ThisWorkbook

ThisWorkbook というのはマクロがあるブックを意味しますから、もう一つの対象である twb をセットしている部分をもう一つのブックに変更します。
Set twb = Workbooks("要求表.xlsx") を "要求シート.xls〇" に変える。

そのうえで、それ以降に出てくる twb となっている部分を ThisWorkbook に、ThisWorkbook となっている部分を twb に変更します。


Sub Test1()
Dim twb As Workbook, r As Range
Dim LRow As Long, tCol As Long

On Error GoTo ER:
Set twb = Workbooks("要求シート.xls〇") '←ちゃんとした拡張子で指定

With twb.Worksheets(1)
tCol = 0
LRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For Each r In .Rows(2).Cells
If r.Value = Date Then
tCol = r.Column
Exit For
End If
Next r
If tCol > 0 Then
Set r = .Range(.Cells(3, 3), .Cells(LRow, 3)).SpecialCells(12)
Set r = Union(r, .Range(.Cells(3, tCol), .Cells(LRow, tCol)).SpecialCells(12))
r.Copy
ThisWorkbook.Worksheets(1).Range("C3").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End With

With twb.Worksheets(2)
tCol = 0
LRow = .Cells(.Rows.Count, "C").End(xlUp).Row
For Each r In .Rows(2).Cells
If r.Value = Date Then
tCol = r.Column
Exit For
End If
Next r
If tCol > 0 Then
Set r = .Range(.Cells(3, 3), .Cells(LRow, 3)).SpecialCells(12)
Set r = Union(r, .Range(.Cells(3, tCol), .Cells(LRow, tCol)).SpecialCells(12))
r.Copy
ThisWorkbook.Worksheets(1).Range("C23").PasteSpecial xlPasteValues
Application.CutCopyMode = False
End If
End With

Exit Sub

ER:
MsgBox Err.Description & vbCrLf & "処理を中止しました。", vbCritical, "異常終了"
End Sub

質問した人からのコメント

2017/7/1 14:43:28

vcx000xcvさん

分かりやすいご説明、ほんとうにありがとうございます。
拡張子は.xlsmでバッチリOKでした(^^)/
大変助かりました。ありがとございました。

ベストアンサー以外の回答

1〜1件/1件中

hmm********さん

2017/7/107:49:10

ThisWorkbook.Worksheets(1)は
元ファイル「要求シート」(sheet1)なので
>このマクロを、貼り付け先ファイルの「要求表」に置いて
↑を行った時はThisWorkbookはマクロの有るBookなのでWorkbooks("要求表.xlsx").Worksheets(1)と、なります
(貼り付け元と貼り付け先が同じになります)
ThisWorkbook.Worksheets(1)を
Workbooks("○○○.xlsx").Worksheets(1)
○○○は貼り付け先のBook名に変更すると出来ますが、貼り付け先が常に同じBookでない場合は
1)貼り付け先Bookを開いて処理する場合
2)既に貼り付け先Bookが開かれいる場合
・貼り付け元・先の二つのみ
・他のBookも開かれている
等状況により方法が異なります

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる