人力検索はてな
モバイル版を表示しています。PC版はこちら
i-mobile

エクセルの質問です。
下記のように、ユーザーがInputBoxを使って必要なところだけ転記するスクリプトを書いたのですが、これを拡張したいと思っております。
シートに同じフォーマットがずらっと並んでいる時に、その該当部分すべてを別シートに転記するにはどうしたらよいでしょうか。
よろしくお願いいたします。

Dim tenki As Range
Set tenki = Application.InputBox( _
Prompt:="セル範囲を選択", _
Title:="セル選択", _
Type:=8)

tenki.Copy Destination:=Sheets("Sheet3").Range("A1")


●質問者: clinejp
●カテゴリ:コンピュータ インターネット
✍キーワード:A1 application AS Destination SET
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● SALINGER
●23ポイント

転記するセルを、ctrlを押しながら複数選択してください。

その部分が指定したシート(この場合はSheet3にコピーします)

inputbox をtypoe=8で使うときはキャンセルを押すとエラーを出すのでトラップしています。

Sub Macro()
 Dim tenki As Range
 Dim ws As Worksheet
 Dim r As Range
 
  '転記先のシートを指定
 Set ws = Worksheets("Sheet3")
 
  'キャンセルを選んだときのためエラートラップ
 On Error GoTo ErrNot
 Set tenki = Application.InputBox(prompt:="セル範囲を選択", Title:="セルを選択", Type:=8)
 On Error GoTo 0
 
 For Each r In tenki
 r.Copy Destination:=ws.Range(r.Address)
 Next
 
 Exit Sub
ErrNot:
End Sub

http://q.hatena.ne.jp/

◎質問者からの返答

ありがとうございます。

書式そのものをコピーするにはどうしたらいいか教えていただけたら幸いです。


2 ● SALINGER
●23ポイント

セルを書式を含め全てをコピーする方法です。

他にもPasteSpecialの引数を変えることで、書式だけとか、数式とかコピーすることができます。

http://634.ayumu-baby.com/vba/vba_menu.html

Sub Macro()
 Dim tenki As Range
 Dim ws As Worksheet
 Dim r As Range
 
  '転記先のシートを指定
 Set ws = Worksheets("Sheet3")
 
  'キャンセルを選んだときのためエラートラップ
 On Error GoTo ErrNot
 Set tenki = Application.InputBox(prompt:="セル範囲を選択", Title:="セルを選択", Type:=8)
 On Error GoTo 0
 
 For Each r In tenki
 r.Copy
 ws.Range(r.Address).PasteSpecial Paste:=xlAll, _
 Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 Next
 
 Application.CutCopyMode = False
 
 Exit Sub
ErrNot:
End Sub
◎質問者からの返答

大変ありがとうございます。

もうひとつお願いできますでしょうか。

私の質問文が分かりにくかったのですが、複数のシートを結合したいので、現状ですと別シートのデータをを拾った時に上書きされてしまうと思います。

行方向に、選択したデータを次々に順番に転記するということはできますでしょうか。


3 ● SALINGER
●22ポイント

2パターン作ってみました。お好きなほうをどうぞ。


列位置を保持してコピーしています。

ただし、2行以上を選択しないでください。複数行を選択するとおかしな動作になります。

Sub Macro1()
 Dim tenki As Range
 Dim ws As Worksheet
 Dim r As Range
 Dim w As Worksheet
 Dim myRow As Long
 
  '転記先のシートを指定
 Set ws = Worksheets("Sheet3")
 
  'キャンセルを選んだときのためエラートラップ
 On Error GoTo ErrNot
 Set tenki = Application.InputBox(prompt:="セル範囲を選択", Title:="セルを選択", Type:=8)
 On Error GoTo 0
 
 ws.Cells.Clear
 myRow = 1
 For Each w In Worksheets
 If w.Name <> ws.Name Then
 For Each r In tenki
 w.Range(r.Address).Copy
 ws.Cells(myRow, r.Column).PasteSpecial Paste:=xlAll, _
 Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 Next
 myRow = myRow + 1
 End If
 Next w
 
 Application.CutCopyMode = False
 
 Exit Sub
ErrNot:
End Sub

左詰でコピーします。

複数行選択可能です。複数範囲を選択した場合はエラーになることがあります。

Sub Macro2()
 Dim tenki As Range
 Dim ws As Worksheet
 Dim r As Range
 Dim w As Worksheet
 Dim myRow As Long
 
  '転記先のシートを指定
 Set ws = Worksheets("Sheet3")
 
  'キャンセルを選んだときのためエラートラップ
 On Error GoTo ErrNot
 Set tenki = Application.InputBox(prompt:="セル範囲を選択", Title:="セルを選択", Type:=8)
 On Error GoTo 0
 
 ws.Cells.Clear
 myRow = 1
 For Each w In Worksheets
 If w.Name <> ws.Name Then
 w.Range(tenki.Address).Copy
 ws.Cells(myRow, 1).PasteSpecial Paste:=xlAll, _
 Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 myRow = myRow + tenki.Rows.Count
 End If
 Next w
 
 Application.CutCopyMode = False
 
 Exit Sub
ErrNot:
End Sub

http://q.hatena.ne.jp/

◎質問者からの返答

ありがとうございます。

やりたかったイメージどおりです。

すみません、何度も。

当方エクセルのバージョンが2002なのですが、転記の際に書式のコピーが行われません。

これはバージョンの問題でしょうか。


4 ● SALINGER
●22ポイント

3の回答の上のほうの列幅と行の高さ版です。

Sub Macro1()
 Dim tenki As Range
 Dim ws As Worksheet
 Dim r As Range
 Dim w As Worksheet
 Dim myRow As Long
 
  '転記先のシートを指定
 Set ws = Worksheets("Sheet3")
 
  'キャンセルを選んだときのためエラートラップ
 On Error GoTo ErrNot
 Set tenki = Application.InputBox(prompt:="セル範囲を選択", Title:="セルを選択", Type:=8)
 On Error GoTo 0
 
 ws.Cells.Clear
 myRow = 1
 For Each w In Worksheets
 If w.Name <> ws.Name Then
 For Each r In tenki
 w.Range(r.Address).Copy
 ws.Cells(myRow, r.Column).PasteSpecial Paste:=xlAll, _
 Operation:=xlNone, SkipBlanks:=False, Transpose:=False
 ws.Cells(myRow, r.Column).ColumnWidth = w.Range(r.Address).ColumnWidth
 ws.Cells(myRow, r.Column).RowHeight = w.Range(r.Address).RowHeight
 Next
 myRow = myRow + 1
 End If
 Next w
 
 Application.CutCopyMode = False
 
 Exit Sub
ErrNot:
End Sub

余談ですが、2の回答のリンク先にある列幅をコピーする方法は

xlColumnWidthsではなくxlPasteColumnWidthsの間違いですね。

http://q.hatena.ne.jp/

◎質問者からの返答

大変ありがとうございました。

また今度もよろしくお願いいたします。

関連質問


●質問をもっと探す●



0.人力検索はてなトップ
8.このページを友達に紹介
9.このページの先頭へ
対応機種一覧
お問い合わせ
ヘルプ/お知らせ
ログイン
無料ユーザー登録
はてなトップ