ここから本文です

ExcelVBAで特定のセルの値を別ブックにコピーしていく方法を教えてください

sadakichi0303さん

2009/5/1721:06:03

ExcelVBAで特定のセルの値を別ブックにコピーしていく方法を教えてください

Excelでテストの解答用紙を作成しました。このシートに入力された学籍番号や氏名、入力された答えの値だけを別のブックに書き出したいのですが、下記の式の中でいくつか不明点があります。


解答用紙は1つのブック内に最大60枚(シート名は学籍番号)あり、書き出したい値はすべて同じ位置に値が入っています。
書き出し先のシートの1行目には、項目名が入力されており、2行目以降に各シートの値を貼り付けたいと考えています。

現在考えたのでは、

Private Sub Worksheet_Activate()
Dim writeSheet As Worksheet ' 書き出し先シート
Set writeSheet = ThisWorkbook.ActiveSheet ' Sheet1 を参照

Dim readBook As Workbook ' 相手ブック
Set readBook = Workbooks.Open("書き出し元ブック名") ' 書き出し元ブックを開く
Dim readSheet As Worksheet ' 書き出し元シート
Set readSheet = readBook.Worksheets("1234578901") ' 書き出し元シートを参照

writeSheet.Cells(2, 1).Value = readSheet.Cells(3, 3).Value ' 書き出し元シートの C3 の値を書き出し先の A2 に書き込む
writeSheet.Cells(2, 2).Value = readSheet.Cells(3, 6).Value ' 書き出し元の F3 の値を書き出し先の B2 に書き込む
writeSheet.Cells(2, 3).Value = readSheet.Cells(6, 1).Value ' 書き出し元の A6 の値を書き出し先の C2 に書き込む
writeSheet.Cells(2, 4).Value = readSheet.Cells(6, 2).Value ' 書き出し元の B6 の値を書き出し先の D2 に書き込む
・・・これをデータの個数分繰り返す・・・

readBook.Close False ' 書き出し元ブックを閉じる
Set readSheet = Nothing
Set readBook = Nothing
End Sub

としています。

別シートも自動的に見て書き出すには、どうすればよいでしょうか。

Excel2007を使っていますが、2003の環境でできるようにしたいと考えています。

閲覧数:
14,767
回答数:
2
お礼:
250枚

違反報告

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

vcx000xcvさん

編集あり2009/5/1722:14:52

内容的にシートのアクティブイベントに記載するような処理とは思えません。
シートがアクティブになるたびに、こんな処理が走ったら作業する方はたまらんでしょう。

CommandButton などを配置してクリックイベントで行うなどが普通だと思います。

「書き出し元」に60枚程度のシートがあり、それを全部処理したいって事なら、下記のような感じでループさせます。
実際に業務で使うなら細かくエラー処理を施した方が無難です。

例は標準モジュールへの記載を前提に書いています。

Sub Test()
Dim writeSheet As Worksheet ' 書き出し先シート
Dim readBook As Workbook ' 相手ブック
Dim readSheet As Worksheet ' 書き出し元シート
Dim LRange As Long, Cnt As Long, readAddr

readAddr = Array("C3", "F3", "A6", "B6") '書き出し元のセル

Set writeSheet = ThisWorkbook.Worksheets("Sheet1") ' Sheet1 を参照
Set readBook = Workbooks.Open("書き出し元ブック名") ' 書き出し元ブックを開く
For Each readSheet In readBook.Worksheets
With writeSheet
LRow = .Cells(.Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For Cnt = 0 To UBound(readAddr)
.Cells(LRow, Cnt + 1).Value = readSheet.Range(readAddr(Cnt)).Value
Next Cnt
End With
Next
readBook.Close False ' 書き出し元ブックを閉じる
End Sub

---補足---

2009/05/17 21:55
少し直しました。

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

2009/5/17 23:44:54

降参 ありがとうございます。シート1枚を走らせただけですが、思っていたことができました。
感謝いたします。ありがとうございました。

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

1〜1件/1件中

k032yfさん

2009/5/1721:14:44

Private Sub 問題選択_Click()
Dim thisSheet As Worksheet
Dim x1 As Integer, y1 As Integer, y2 As Integer
Dim x As Integer
swc = 0
Set thisSheet = Sheets("問題集")
Sheets("パズル").Select
Range("h14") = ""
x1 = Cells(16, 4)
x = Val(InputBox("問題数の範囲の数値を入力して下さい", "問題選択", "5"))
If x > 0 And x < x1 + 1 Then
y2 = 12 * (x - 1) + 2
For y1 = 3 To 13
For x1 = 2 To 10
Cells(y1, x1) = thisSheet.Cells(y2, x1)
Next x1
y2 = y2 + 1
Next y1
End If
Range("a16").Select
End Sub

あわせて知りたい

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

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

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

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

閉じる

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