[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『ワークシートクラスのペーストメソッドが失敗しました、を解決したい』（ふみ）
皆さん、こんにちは。
簡単そうで、どうしても解決出来ないので御相談です。
下記コードで、コピー元のブックを閉じてからコードを走らせると
問題無いのですが、閉じない状態で走らせると、 ActiveSheet.Paste
のところで「失敗しました」となってしまいます。
作業上、コピー元のブックを閉じずに実行させたくて、
Selection.PasteSpecial Pasteとか、いろいろやってみたのですが、
どうしてもうまくいきません。
どうしたら良いか御教示下さい。よろしくお願いします。
Sub 貼付()
'
' Sheet1,Sheet2を消去後、Sheet2に購入品のデータ貼付 Sheet1にデータ読込転記
'
'
Sheets("Sheet1").Range("A10:I1008").Select
Selection.ClearFormats
Range("A10:I1008").Select
Selection.ClearContents
Dim ob As Shape
With ActiveSheet
For Each ob In .Shapes
If Not Intersect(ob.TopLeftCell, .Range("A10:I1008")) Is Nothing Then
ob.Delete
End If
Next
End With
Sheets("Sheet2").Select
Range("A1:AO1000").Select
Selection.ClearFormats
Range("A1:AO1000").Select
Selection.ClearContents
Dim oj As Shape
With ActiveSheet
For Each oj In .Shapes
If Not Intersect(oj.TopLeftCell, .Range("A1:AO1000")) Is Nothing Then
oj.Delete
End If
Next
End With
Windows("見積作成データ変換.xlsm").Activate
Sheets("Sheet2").Select
Range("A1").Select
ActiveSheet.Paste
' 全角を半角へ変換
Sheets("Sheet2").Range("D2:D1000").Select
Dim d As Range
For Each d In Selection
d.Value = StrConv(d.Value, vbNarrow)
Next d
Sheets("Sheet2").Range("I2:I1000").Select
Dim i As Range
For Each i In Selection
i.Value = StrConv(i.Value, vbNarrow)
Next i
' 半角を全角へ変換
Sheets("Sheet2").Range("G2:G1000").Select
Dim g As Range
For Each g In Selection
g.Value = StrConv(g.Value, vbWide)
Next g
Sheets("Sheet2").Range("J2:J1000").Select
Dim j As Range
For Each j In Selection
j.Value = StrConv(j.Value, vbWide)
Next j
Sheets("Sheet2").Range("D2:D1000").Copy Sheets("Sheet1").Range("A10")
Application.CutCopyMode = False
Sheets("Sheet2").Range("G2:G1000").Copy Sheets("Sheet1").Range("B10")
Application.CutCopyMode = False
Sheets("Sheet2").Range("I2:I1000").Copy Sheets("Sheet1").Range("C10")
Application.CutCopyMode = False
Sheets("Sheet2").Range("J2:J1000").Copy Sheets("Sheet1").Range("D10")
Application.CutCopyMode = False
Sheets("Sheet2").Range("O2:O1000").Copy Sheets("Sheet1").Range("E10")
Application.CutCopyMode = False
Sheets("Sheet1").Select
Range("A1").Select
End Sub
＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
処理の内容が良くわかりませんが、コードが標準モジュールであれば、Sheets(...) の 指定では、現在表示されているブックが対象となります。
ですので、提示のコードはマクロを実行するときに、アクティブなファイルやシートが 変わると結果も異なると思います。
複数のファイルにまたがる処理であれば、Select で対象を切替えるのではなく、明示的に Workbooks(ファイル名).Worksheets(シート名).... というように指定すれば、表示状態がどのようであっても期待通りに処理されると思います。 （Mook） 2014/05/07(水) 19:09
コピー元のcsvファイルはたくさんあって名前がそれぞれ違うので、コードで名前を指定する事が出来ず、
「アクティブシート」としか指定出来なくて困っています。
コピー元のcsvファイルのシートをコピー状態にしたまま、csvファイルを閉じてクリップボードに保存させて
実行すると期待通りに処理されますが、これを閉じないで、コピー状態のファイルのデータを
クリップボードに保存させる事が出来ないでしょうか？
よろしくお願いします。
（ふみ） 2014/05/08(木) 08:53
>コピー元のcsvファイルはたくさんあって名前がそれぞれ違うので、コードで名前を指定する事が出来ず、 とあきらめてしまうのではなく、どのように対象ブックを指定するか解決する方向で 考えたほうが良いように思います。
アクティブシートを対象にというのは、他に津シートを対象にしたマクロでは、それほど問題 になりませんが、ファイル間、シート間の処理では Select を繰り返し、結果コードを見ても 可読性が悪かったり、処理が遅かったり、処理中にユーザが EXCELを触って処理がおかしく なったり、と余りいいことがありません。
上記のコードでは、途中
Windows("見積作成データ変換.xlsm").Activate
とありますが、その前の処理はどのファイルのシートを対象に処理しているのでしょうか。
また、CSV ファイルは同時に複数開くこともあるのでしょうか。
コードの修正を考えるにも、まずはそのあたりをクリアにしたいと思います。 （Mook） 2014/05/08(木) 10:13
csvファイルを開くのは１ファイルだけです。同時に複数は開きません。
またcsvファイルは開いて１シート全体をコピーするだけで、他には何もしません。
Windows("見積作成データ変換.xlsm").Activate
の前の処理は見積作成データ変換ファイルのシート１とシート２のデータを消去しています。
消去ボタンも用意しているのですが、消去忘れ防止の為、データをペーストする前に
以前のデータを消去する様にしています。
ちなみに、この消去のコードを消して、いきなりペーストすると、csvファイルを
閉じていなくても、問題なく動作しました。
消極的な解決で、これで一応、使う事は出来ますが、出来れば消去忘れ防止は
残しておきたいと思うので、自分でも引き続きいろいろやってみます。
（ふみ） 2014/05/08(木) 10:56
どうしてそうなるか、よく解析していませんが、とりあえずすべての処理に シート（ブックを含む）を区別して指定するよう変更しました。
下記でもエラーが出るでしょうか。 ただしマクロがあるファイルが、「見積作成データ変換.xlsm」である前提です。
Sub 貼付()
'「見積作成データ変換.xlsm」 の Sheet1,Sheet2を消去後、Sheet2に購入品のデータ貼付 Sheet1にデータ読込転記
Dim 見積作成_WS1 As Worksheet
Set 見積作成_WS1 = ThisWorkbook.Worksheets("Sheet1")
Dim 見積作成_WS2 As Worksheet
Set 見積作成_WS2 = ThisWorkbook.Worksheets("Sheet2")
見積作成_WS1.Range("A10:I1008").ClearFormats
見積作成_WS1.Range("A10:I1008").ClearContents
Dim sh As Shape
For Each sh In 見積作成_WS1.Shapes
If Not Intersect(sh.TopLeftCell, 見積作成_WS1.Range("A10:I1008")) Is Nothing Then sh.Delete
Next
見積作成_WS2.Range("A1:AO1000").ClearFormats
見積作成_WS2.Range("A1:AO1000").ClearContents
For Each sh In 見積作成_WS2.Shapes
If Not Intersect(sh.TopLeftCell, 見積作成_WS2.Range("A1:AO1000")) Is Nothing Then sh.Delete
Next
Dim CSV_WS As Worksheet
Dim wb As Workbook
Dim csvCount As Long
For Each wb In Workbooks
If InStr(LCase(wb.Name), ".csv") > 0 Then
Set CSV_WS = wb.Worksheets(1) '// 先頭シートを指定
csvCount = csvCount + 1
End If
Next
If csvCount <> 1 Then
If csvCount = 0 Then MsgBox "CSV ファイルがありません。"
If csvCount > 1 Then MsgBox "CSV が複数開いています。"
Exit Sub
End If
CSV_WS.Cells.Copy 見積作成_WS2.Cells
' 全角を半角へ変換
変換 見積作成_WS2.Range("D2:D1000"), vbNarrow
変換 見積作成_WS2.Range("I2:I1000"), vbNarrow
' 半角を全角へ変換
変換 見積作成_WS2.Range("G2:G1000"), vbWide
変換 見積作成_WS2.Range("J2:J1000"), vbWide
見積作成_WS2.Range("D2:D1000").Copy 見積作成_WS1.Range("A10:A1008")
見積作成_WS2.Range("G2:G1000").Copy 見積作成_WS1.Range("B10:B1008")
見積作成_WS2.Range("I2:I1000").Copy 見積作成_WS1.Range("C10:C1008")
見積作成_WS2.Range("J2:J1000").Copy 見積作成_WS1.Range("D10:D1008")
見積作成_WS2.Range("O2:O1000").Copy 見積作成_WS1.Range("E10:E1008")
見積作成_WS1.Activate
Range("A1").Activate
End Sub
Sub 変換(rng As Range, md As Long)
Dim tbl
tbl = rng
Dim r As Long
Dim c As Long
For r = 1 To UBound(tbl, 1)
For c = 1 To UBound(tbl, 2)
tbl(r, c) = StrConv(tbl(r, c), md)
Next
Next
rng = tbl
End Sub
（Mook） 2014/05/08(木) 11:43
実はもう１件、諦めているコードがあります。
桁数が決まっていないデータが複数あり、データの最後にPとRの記号が入っていたりいなかったり
しています。このデータのそれぞれの最後にP1R1を追加するのですが、PやRが入っている場合は
PはP1に変換してP1R1は追加しません。RはRだけの場合はR1に変換し、Rの後ろに数字が入っていれば
何もしません。最終的に全てのデータの最後をP1R○としたいのですが、元のデータにPやRが
入っているかどうかを調べるコードがわかりません。
この質問をあらためて別の機会にしますので、よかったら御教示下さい。
ありがとう御座いました。
（ふみ） 2014/05/08(木) 13:40
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.