ブック①はB列に作業員の名前が30人入っていて、C列に作業メモが入っています。どのセルもテキストデータです。
このメモを下段のブック②の各30シートに振り分けます。作業員の名前がシート名になっています。作業メモをテキストボックス(分かりやすいようにオレンジにしました)にペーストします。※印は改行に置換してください。そして、このメモは日付とともにどんどん増えていくので、加えていくようにします。また、このページはどんどん増えていくので、H2セルの数に合わせて、つまり2が表示されたら、上から2つめのテキストボックス(1ページは27行なので、28行以降のページのテキストボックスです)に書き加えていきます。なお、ブック①とブック②は同じフォルダに入れています。バージョンは2002です。説明がわかりにくいかもしれませんが、よろしくお願いします。
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
とりあえず作ってみました。
作業の記録のほうは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ページを存在させてから、このマクロを実施したいと思います。仕様の説明が大変遅れて申し訳ありません。
ブック①.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
かなりていねいにお答えいただいているので、「できました!」と言いたい所なんですが、駄目です。シート名をチェックしているのもわかりますし、ブック①や②が互いに存在チェックしているんだろうなあ、と想像できますが、データがペーストされる段階で、その前に終了している感じです。もしかして、ブック②の方に緑のプラスと赤のバツマーク(オブジェクト)があるのは関係していますか?ページを増やしたり、減らしたりするマクロを入れてあるものなんですが、これが邪魔しているのかな?
勝手にテキストボックスといえば、コントロールツールボックスのテキストボックスをシート上に配置したものと思ってました。
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回目の場合はペーストされません。これは、データが入っているテキストボックスにペーストさせることができない状況と同じです。もう少しです。対応をお願いします。
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日間も、しかも早急に作成してくださいまして感謝、感謝です。今回のが前回とどのように違っているのかをプリントアウトして、勉強したいと思います。お世話になりました。
大変ありがとうございました。思い通りの結果です。3日間も、しかも早急に作成してくださいまして感謝、感謝です。今回のが前回とどのように違っているのかをプリントアウトして、勉強したいと思います。お世話になりました。