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


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

回答の条件
  • 1人5回まで
  • 登録:
  • 終了:2009/02/17 22:06:31
※ 有料アンケート・ポイント付き質問機能は2023年2月28日に終了しました。

ベストアンサー

id:SALINGER No.4

回答回数3454ベストアンサー獲得回数969

ポイント100pt

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
id:anglar

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

2009/02/17 22:04:32

その他の回答3件)

id:SALINGER No.1

回答回数3454ベストアンサー獲得回数969

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

作業の記録のほうは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
id:anglar

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

2009/02/15 19:40:44
id:SALINGER No.2

回答回数3454ベストアンサー獲得回数969

ブック①.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
id:anglar

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

2009/02/15 21:45:39
id:SALINGER No.3

回答回数3454ベストアンサー獲得回数969

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

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
id:anglar

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

2009/02/16 19:48:53
id:SALINGER No.4

回答回数3454ベストアンサー獲得回数969ここでベストアンサー

ポイント100pt

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
id:anglar

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

2009/02/17 22:04:32
  • id:SALINGER
    仕様についてお尋ねします。
    テキストボックスの大きさですが、Range("D4:F27")に重なる大きさでしょうか。
    その下のテキストボックスは、Range("D28:F51")となりますか?
    テキストボックスはあらかじめシートにあるということでよろしいですか?
  • id:anglar
    あらかじめテキストボックスのMulthLineをTrueする方法はどうやるんですか?また、本質じゃなくても、ブック②の存在チェックをして自動で開くというのも記述されていたらうれしいです。
  • id:SALINGER
    変更箇所として
    9行目
    For i = 2 To lastRow

    For i = 4 To lastRow

    21行目
    If oleOb.TopLeftCell.Row = (sh.Range("H2").Value - 1) * 24 + 4 Then

    If oleOb.TopLeftCell.Row = (sh.Range("H2").Value - 1) * 27 + 4 Then
    でうまくいきませんか?
    同じようなファイルを作ってテストしていますが、自分の場合はうまくいっています。
  • id:anglar
    むむむ。ご指摘の部分は自分でも直してみましたが駄目です。

    なお、関係ないかもしれませんが、「○○という名前のシートがありません」というメッセージが出ています。ブック①でマクロを動かしていますが、おそらくブック②に存在しているシートを、ブック①にはないというメッセージになっていると思います。データがコピペされないのは、ブック①からブック②が見えていないということかと思います。
  • id:SALINGER
    MulthLineですが、デザインモードでテキストボックスを選択状態にして、右クリックからプロパティで開く画面の中にMulthLineというのがありますので、そこを変更します。
  • id:Mook
    これをテキストボックスで実装する必要性は何かありますか?

    24行のセルを通常のセルとして使用して、罫線の表示で一つのセルのように見せれば実装上も
    表示上もかなりシンプルになると思うのですが。
  • id:anglar
    SALINGERさんへ
    もしかして、デザインモードということは、ユーザーフォームのテキストボックスということでしょうか?私が使っているのは、フォームではなく、普通に入れられるテキストを表示させるテキストボックスですが。
    Mookさんへ
    通常のセルにして、ワープロのように期日ごとのデータをレイアウトよく表示させることが出来るんですか?
  • id:SALINGER
    やはり、コントロールツールボックスのテキストボックスではなかったのですね。
    ということは、Shapeになるのかな。
  • id:Mook
    「ワープロのように」がどの程度のものを期待されているかによりますが、
    セルでもフォントやサイズは指定は可能です。

    EXCEL は表計算ソフトですから、事細かな体裁は制御できませんが、期日ごとの
    レイアウトというのは、どのようなものを指しているでしょうか。

    ※によって改行を行うというのは、これによって次のセルに入力を変える
    ということになりますが、これでは不十分でしょうか。
    1ページ分に相当する部分の内部の罫線を非表示にしておけば、印刷時は普通の
    四角い枠の中に文章が並んだ状態になるかと思います。

    ワープロでいう行間はセルの高さで調節することになるかと思います。
    なので、A:C列のデータと D列のデータの行間を非同期にして記載したい
    ということであれば、今回のようにテキストボックスを使用することになりますが、
    A:C列はどのようにお使いですか?
  • id:anglar
    Mookさんへ。レイアウトとは特にありません。期日(改行)作業メモ(改行)(改行)次の期日・・・という感じで、データがどんどんたまっていってほしいです。ご指摘のとおりです。
    B列は使っていますが、A列、C列は使っていません。「A:C列のデータと D列のデータの行間を非同期にして記載したい」という予定はありません。テキストボックスを使わない方法というのに興味がわきます。
  • id:SALINGER
    Excel2002で違うのかな・・・。自分の環境ではできてるんですが。
    因みにテキストボックスに追記していくようになっています。
  • id:SALINGER
    できればマクロの自動記録で、テキストボックスに文字を書き込むという動作を記録すると、標準モジュールにコードができるのでそれをコメント欄にコピペして見せていただけませんか?
  • id:anglar
    遅くなりました。自動記録では2ページ目に、つまりtextbox2に入れるマクロになっていたはずだったのに、実際は存在しないtextbox3をセレクトしています。しかも、"data1"から"data7"は、本当は長々とした文字列なのですが、これは、もともと対象外である1ページ目のtextbox1に入っていたデータです。ブック②の方に緑のプラスと赤のバツマーク(shapeオブジェクト)があるのが邪魔しているのでしょうか?

    Sub Macro1()
    ' マクロ記録日 : 2009/2/16 ユーザー名 : anglar
    '
    ActiveSheet.Shapes("Text Box 3").Select
    Selection.Characters.Text = _
    "4月18日(金)" & Chr(10) & "data1" & Chr(10) & "" & Chr(10) & "5月13日(火)" & Chr(10) & "data2"
    Selection.Characters(201).Insert String:= _
    "data2" & Chr(10) & "" & Chr(10) & "6月2日(月)" & Chr(10) & "data3"
    Selection.Characters(401).Insert String:= _
    "data3" & Chr(10) & "" & Chr(10) & "6月13日(金)" & Chr(10) & "data4"
    Selection.Characters(601).Insert String:= _
    "" & Chr(10) & "" & Chr(10) & "7月8日(火)" & Chr(10) & "data5" & Chr(10) & "" & Chr(10) & "7月29日(火)" & Chr(10) & "data5"
    Selection.Characters(801).Insert String:= _
    "data5"
    Selection.Characters(1001).Insert String:= _
    "data5" & Chr(10) & "" & Chr(10) & "10月8日(水)" & Chr(10) & "data6"
    Selection.Characters(1201).Insert String:= _
    "data6" & Chr(10) & "" & Chr(10) & "11月17日(月)" & Chr(10) & "data7" & Chr(10) & "" & Chr(10) & ""
    With Selection.Characters(Start:=1, Length:=1325).Font
    .Name = "MS Pゴシック"
    .FontStyle = "標準"
    .Size = 11
    .Strikethrough = False
    .Superscript = False
    .Subscript = False
    .OutlineFont = False
    .Shadow = False
    .Underline = xlUnderlineStyleNone
    .ColorIndex = xlAutomatic
    End With
    End Sub
  • id:SALINGER
    理由がわかりました。255文字以上を一度に入力しようとするとブランクになるようです。
  • id:SALINGER
    他のshapeオブジェクトはテキストボックスの一番上の行に無ければ問題はないはずです。
  • id:SALINGER
    なんとかできたようで良かったです。何度もわずらわせて申し訳ありませんでした。
  • id:Mook
    無事できたようで、何よりです。

    結果的に余計なコメントをしただけとなって失礼しました。

この質問への反応(ブックマークコメント)

「あの人に答えてほしい」「この質問はあの人が答えられそう」というときに、回答リクエストを送ってみてましょう。

これ以上回答リクエストを送信することはできません。制限について

回答リクエストを送信したユーザーはいません