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

エクセルのVBAでお願いします。添付画像のように上段のブック?から下段のブック?へデータをペーストします。

ブック?はB列に作業員の名前が30人入っていて、C列に作業メモが入っています。どのセルもテキストデータです。
このメモを下段のブック?の各30シートに振り分けます。作業員の名前がシート名になっています。作業メモをテキストボックス(分かりやすいようにオレンジにしました)にペーストします。※印は改行に置換してください。そして、このメモは日付とともにどんどん増えていくので、加えていくようにします。また、このページはどんどん増えていくので、H2セルの数に合わせて、つまり2が表示されたら、上から2つめのテキストボックス(1ページは27行なので、28行以降のページのテキストボックスです)に書き加えていきます。なお、ブック?とブック?は同じフォルダに入れています。バージョンは2002です。説明がわかりにくいかもしれませんが、よろしくお願いします。

1234617645
●拡大する

●質問者: anglar
●カテゴリ:コンピュータ
✍キーワード:エクセル オレンジ セル テキスト データ
○ 状態 :終了
└ 回答数 : 4/4件

▽最新の回答へ

1 ● SALINGER
●0ポイント

とりあえず作ってみました。

作業の記録のほうは2行目からデータが入っているとして、

ブック?の標準モジュールにコードを書き込み、ブック?とブック?を開いてブック?をアクティブにして実行してください。


(ブック?の存在チェックをして自動で開いてもよかったのですが、本質じゃないので省略)

テキストボックスの位置が図から判断すると、Range("D4:F27")、次がRange("D28:F51")と解釈しました。

違う場合はコード中でテキストボックスの左上のセルを判別する「* 24 + 4」というところが変更となります。


※を改行コードに置換するようにしていますが、あらかじめテキストボックスのMulthLineをTrueにしておかないと改行されないので注意。


Sub sagyouRec()
 Dim lastRow As Long
 Dim i As Long
 Dim oleOb As OLEObject
 Dim sh As Worksheet
 Dim mes As String
 Dim f As Boolean
 
 lastRow = Cells(Rows.Count, 2).End(xlUp).Row
 For i = 2 To lastRow
 f = False
 For Each sh In Workbooks("ブック?.xls").Worksheets
 If sh.Name = Cells(i, 2).Value Then
 f = True
 Exit For
 End If
 Next
 If f Then
 mes = Replace(Cells(i, 3).Value, "※", vbNewLine)
 If mes <> "" Then
 For Each oleOb In sh.OLEObjects
 If oleOb.TopLeftCell.Row = (sh.Range("H2").Value - 1) * 24 + 4 Then
 oleOb.Object.Value = oleOb.Object.Value & mes & vbNewLine
 End If
 Next
 End If
 Else
 MsgBox Cells(i, 2).Value & "という名前のシートがありません"
 End If
 Next
End Sub
◎質問者からの返答

早々と作っていただき、感謝です。しかし、エラーは出ていませんが、データは動いていません。添付画像は説明のために作ったもので、実際の列番号、行番号ではないのですが、その部分を直してもうまく動きません。ブック?の1はA4セル、作業員01はB4セル、その隣はBC4セルです。ブック?のテキストボックスはRange("D4:F27")、次がRange("D31:F54")です。テキストボックスは最初のものはあらかじめシートにありますが、次は必要に応じて別のマクロで増やしていきます。2ページにコピペするときは2ページを存在させてから、このマクロを実施したいと思います。仕様の説明が大変遅れて申し訳ありません。


2 ● SALINGER
●0ポイント

ブック?.xlsの作業の記録のシート名がわからなかったので、Sheet1という名前にしています。

違う場合は変更してください。

>「○○という名前のシートがありません」が出る。

ブック?のB列とブック?のシート名が違うと出ます。出る場合は違っていないか確認してください。(全角半角余分なスペースなど)


Option Explicit

Sub sagyouRec()
 Dim lastRow As Long
 Dim i As Long
 Dim oleOb As OLEObject
 Dim sh As Worksheet
 Dim mes As String
 Dim f As Boolean
 Dim wb As Workbook
 Dim ws As Worksheet
 
  '作業の記録のシート名に変更してください。
 Set ws = Workbooks("ブック?.xls").Worksheets("Sheet1")
 
  'ブックの存在チェックと、既に開いている場合のチェックです。
 On Error Resume Next
 Err.Clear
 Set wb = Workbooks("ブック?.xls")
 If Err.Number > 0 Then
 Err.Clear
 Set wb = Workbooks.Open(ThisWorkbook.Path & "\ブック?.xls")
 If Err.Number > 0 Then
 MsgBox "ブック?.xlsを開くことができません"
 On Error GoTo 0
 Exit Sub
 End If
 End If
 On Error GoTo 0
 
 lastRow = ws.Cells(Rows.Count, 2).End(xlUp).Row
 For i = 4 To lastRow
 f = False
 For Each sh In wb.Worksheets
 If sh.Name = ws.Cells(i, 2).Value Then
 f = True
 Exit For
 End If
 Next
 If f Then
 mes = Replace(ws.Cells(i, 3).Value, "※", vbNewLine)
 If mes <> "" Then
 For Each oleOb In sh.OLEObjects
 If oleOb.TopLeftCell.Row = (sh.Range("H2").Value - 1) * 27 + 4 Then
 oleOb.Object.Value = oleOb.Object.Value & mes & vbNewLine
 End If
 Next
 End If
 Else
 MsgBox ws.Cells(i, 2).Value & "という名前のシートがありません"
 End If
 Next
End Sub
◎質問者からの返答

かなりていねいにお答えいただいているので、「できました!」と言いたい所なんですが、駄目です。シート名をチェックしているのもわかりますし、ブック?や?が互いに存在チェックしているんだろうなあ、と想像できますが、データがペーストされる段階で、その前に終了している感じです。もしかして、ブック?の方に緑のプラスと赤のバツマーク(オブジェクト)があるのは関係していますか?ページを増やしたり、減らしたりするマクロを入れてあるものなんですが、これが邪魔しているのかな?


3 ● SALINGER
●0ポイント

勝手にテキストボックスといえば、コントロールツールボックスのテキストボックスをシート上に配置したものと思ってました。

Excel2002にはWordのようにテキストボックスの挿入があったのかな。

たぶん、実態はShapeだと思うのでこれでいけると思うのですが。


Option Explicit

Sub sagyouRec()
 Dim lastRow As Long
 Dim i As Long
 Dim shp As Shape
 Dim sh As Worksheet
 Dim mes As String
 Dim f As Boolean
 Dim wb As Workbook
 Dim ws As Worksheet
 
 Set ws = Workbooks("ブック?.xls").Worksheets(1)
 
  'ブックの存在チェックと、既に開いている場合のチェックです。
 On Error Resume Next
 Err.Clear
 Set wb = Workbooks("ブック?.xls")
 If Err.Number > 0 Then
 Err.Clear
 Set wb = Workbooks.Open(ThisWorkbook.Path & "\ブック?.xls")
 If Err.Number > 0 Then
 MsgBox "ブック?.xlsを開くことができません"
 On Error GoTo 0
 Exit Sub
 End If
 End If
 On Error GoTo 0
 
 lastRow = ws.Cells(Rows.Count, 2).End(xlUp).Row
 For i = 4 To lastRow
 f = False
 For Each sh In wb.Worksheets
 If sh.Name = ws.Cells(i, 2).Value Then
 f = True
 Exit For
 End If
 Next
 If f Then
 mes = Replace(ws.Cells(i, 3).Value, "※", vbNewLine)
 If mes <> "" Then
 sh.Activate
 For Each shp In sh.Shapes
 If shp.TopLeftCell.Row = (sh.Range("H2").Value - 1) * 27 + 4 Then
 shp.Select
 Selection.Characters.Text = Selection.Characters.Text & mes & vbNewLine
 End If
 Next
 End If
 Else
 MsgBox ws.Cells(i, 2).Value & "という名前のシートがありません"
 End If
 Next
End Sub
◎質問者からの返答

ありがとうございます。一歩前進しました。というのは、全てのシートのテキストボックスがアクティブになった形跡があるのですが、コピーは出来ていません。ちなみに、テキストボックス内のデータを全て削除しておくと、予定通り全てペーストされます。しかし、2回目は※印のないデータを実験として入れておくと、全て予定通りペーストされますが、※印のあるデータは2回目の場合はペーストされません。これは、データが入っているテキストボックスにペーストさせることができない状況と同じです。もう少しです。対応をお願いします。


4 ● SALINGER
●100ポイント ベストアンサー

100文字ごとに書き込むように変更しました。

Option Explicit

Sub sagyouRec()
 Dim lastRow As Long
 Dim i As Long
 Dim shp As Shape
 Dim sh As Worksheet
 Dim mes As String
 Dim f As Boolean
 Dim wb As Workbook
 Dim ws As Worksheet
 Dim j As Long
 Dim k As Integer
 
 Set ws = Workbooks("ブック?.xls").Worksheets(1)
 
  'ブックの存在チェックと、既に開いている場合のチェックです。
 On Error Resume Next
 Err.Clear
 Set wb = Workbooks("ブック?.xls")
 If Err.Number > 0 Then
 Err.Clear
 Set wb = Workbooks.Open(ThisWorkbook.Path & "\ブック?.xls")
 If Err.Number > 0 Then
 MsgBox "ブック?.xlsを開くことができません"
 On Error GoTo 0
 Exit Sub
 End If
 End If
 On Error GoTo 0
 
 lastRow = ws.Cells(Rows.Count, 2).End(xlUp).Row
 For i = 4 To lastRow
 f = False
 For Each sh In wb.Worksheets
 If sh.Name = ws.Cells(i, 2).Value Then
 f = True
 Exit For
 End If
 Next
 If f Then
 mes = Replace(ws.Cells(i, 3).Value, "※", vbNewLine)
 If mes <> "" Then
 sh.Activate
 For Each shp In sh.Shapes
 If shp.TopLeftCell.Row = (sh.Range("H2").Value - 1) * 27 + 4 Then
 mes = mes & vbNewLine
 j = shp.TextFrame.Characters.Count + 1
 For k = 1 To Len(mes) Step 100
 shp.TextFrame.Characters(j, 100).Insert (Mid(mes, k, 100))
 j = j + 100
 Next
 End If
 Next
 End If
 Else
 MsgBox ws.Cells(i, 2).Value & "という名前のシートがありません"
 End If
 Next
End Sub
◎質問者からの返答

大変ありがとうございました。思い通りの結果です。3日間も、しかも早急に作成してくださいまして感謝、感謝です。今回のが前回とどのように違っているのかをプリントアウトして、勉強したいと思います。お世話になりました。

関連質問


●質問をもっと探す●



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