Excel VBA質問箱 IV

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

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


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

69144 / 76738

←次へ　｜　前へ→


	【12114】同じデータごと、新規ブックに貼付け・・

とも - 04/3/24(水) 11:53 -


	引用なし

	パスワード

下記コードこのサイトで『ぴかるさん』に教えていただいたものです☆Ａ列の同じデータごとに行ごとコピーして新規ブックを開いて貼付け・・なんですが、Sheet1ではうまくいきますが、これをSheet2で実行すると
　 ↓
sh.Range(行).Copy Destination:=ActiveSheet.Range("A2")

のところでエラーを起こしてしまいます。（Rangeメソッドは失敗しました。"Worksheet"オブジェクトとエラーメッセージが表示されます。）

ぴかる様、ご覧になっていたらよろしくお願いいたします。
どなたかわかる方、いらっしゃいましたら教えてくださいm(_ _)m
宜しくお願い致します。

Sub 図番ごと新規ブックに保存()

Dim カウント As Integer
Dim 文字 As String
Dim 行 As String
Dim i　 As Long
Dim sh As Worksheet
Dim j　 As Long

　　Set sh = ActiveWorkbook.ActiveSheet　　　'ThisWorkbook.ActiveSheet

　　カウント = 0
　　文字 = Range("A2").Text
　　
　　j = 1
　　
　　For i = 2 To Range("A1").End(xlDown).Row + 1
　　
　　　　If sh.Range("A" & i).Text = 文字 Then
　　　　　　If カウント = 0 Then
　　　　　　　　行 = i & ":" & i
　　　　　　　　カウント = 1
　　　　　　Else
　　　　　　　　行 = 行 & "," & i & ":" & i
　　　　　　End If
　　　　　　
　　　　Else
Application.ScreenUpdating = False

　　　　　　　　Workbooks.Add　　　　　　　　　　　　　　　　
　　　　　　　　sh.Range(行).Copy Destination:=ActiveSheet.Range("A2")

　　　　【Sheet1】　　　　　　　　　　　　　　　　　　　　
　　　　　A　　　　 B　　　　　C　　　　　　　 D　　　　　 E　　　　　　　F
1　　　　親図番　　部番　　　部品ｺｰﾄﾞ　　　部品名　　　新部品コード　新部品名　
2　　　　123　　　　16　　　　D0-00087000　　　　C　　　　D0-16101000　　　　C
3　　　　456　　　　16　　　　D0-00087000　　　　A　　　　D0-16101000　　　　C
4　　　　456　　　　12　　　　D0-00063000　　　　B　　　　D0-15936000　　　　D
5　　　　789　　　　12　　　　D0-00063000　　　　B　　　　D0-15936000　　　　D
6　　　　012　　　　12　　　　D0-00063000　　　　B　　　　D0-15936000　　　　D

　　　　【Sheet2】　　　　　　　　　　　　　　　　　　　　
　　　　　A　　　　　 B　　　　 C　　　　　　 D　　　　　E　　　　　　　F
1　　　　親図番　　　部番　　部品ｺｰﾄﾞ　　　部品名　　　新部品コード　新部品名
2　　　　123　　　　9　　　　C0-02046000　　　　C　　　　　　　　
3　　　　456　　　　12　　　　C0-00169000　　　　A　　　　　　　　
4　　　　456　　　　16　　　　D0-00087000　　　　B　　　　D0-16101000　　　　D
5　　　　789　　　　17　　　　D0-05976000　　　　B　　　　　　　　
6　　　　012　　　　19　　　　E0-00615000　　　　B

0 hits

▼

【12114】同じデータごと、新規ブックに貼付け・・ とも 04/3/24(水) 11:53

≪