エクセルVBAマクロの作成にお付き合いください!

レター、レター文章欄という2つの名前のシートがあります。


レターのシートは、上から下に向けてリストが入っています。


1挿入1
2りんご
3・・
4みかん
5すいか
6終わり

10挿入2
11イチゴ
12オレンジ
13終わり

24挿入10
25お米
26小麦
27終わり

レター文章欄
には、

本日のお勧めです!

挿入1
挿入2
・・
挿入10

お読みいただき、ありがとうございました。


マクロ実行で、挿入1という言葉が消えて、その列に「レター」シートの2~5行迄の言葉が挿入されるようにしたいのです。他の挿入2以降も同様としてください。

レター側は「挿入1」~「終わり」という言葉でその挿入1が終わったものとご判断下さい。

途中、「挿入+数値」を判断基準としていただき、挿入3等はない場合があります。挿入という言葉が無いとマクロ終了とします。

またどの行に挿入1などがくるのかは各シートとも、毎回変わります。

お手数ですが、作成をお願いいたします。

回答の条件
  • 1人5回まで
  • 13歳以上
  • 登録:2010/06/22 13:04:42
  • 終了:2010/06/22 21:44:36

ベストアンサー

id:taknt No.5

きゃづみぃ回答回数13538ベストアンサー獲得回数11982010/06/22 18:48:52

ポイント100pt
Sub Macro1()
    f = 0
    For b = 1 To Worksheets("レター").Range("A65536").End(xlUp).Row
        If Left(Worksheets("レター").Cells(b, "A"), 2) = "挿入" Then
            For g = 1 To Worksheets("レター文章欄").Range("A65536").End(xlUp).Row
                If Worksheets("レター").Cells(b, "A") = Worksheets("レター文章欄").Cells(g, "A") Then
                    e = g
                    Exit For
                End If
            Next g
            f = 1
            c = ""
        Else
            If f = 1 Then
                If Worksheets("レター").Cells(b, "A") = "終わり" Then
                    Worksheets("レター文章欄").Cells(e, "A").Delete Shift:=xlUp
                    f = 0
                Else
                    Worksheets("レター文章欄").Cells(e, "A").Insert Shift:=xlDown
                    Worksheets("レター文章欄").Cells(e, "A") = Worksheets("レター").Cells(b, "A")
                    e = e + 1
                End If
            End If
        End If
   Next b
    
End Sub

その他の回答(4件)

id:taknt No.1

きゃづみぃ回答回数13538ベストアンサー獲得回数11982010/06/22 13:49:41

ポイント10pt
Sub Macro1()
    a = Worksheets("レター").Range("A65536").End(xlUp).Row
    z = Worksheets("レター文章欄").Range("A65536").End(xlUp).Row
    f = 0
    For b = 1 To a
        If Left(Worksheets("レター").Cells(b, "A"), 2) = "挿入" Then
            d = Worksheets("レター").Cells(b, "A")
            f = 1
            c = ""
        Else
            If f = 1 Then
                If Worksheets("レター").Cells(b, "A") = "終わり" Then
                     '置換処理
                    For e = 1 To z
                        If Worksheets("レター文章欄").Cells(e, "A") = d Then
                           Worksheets("レター文章欄").Cells(e, "A") = Trim(c)
                        End If
                    Next e
                    
                    f = 0
                Else
                    c = c + " " + Worksheets("レター").Cells(b, "A")
                End If
            End If
        End If
   Next b
    
End Sub
id:naranara19

早速のご回答ありがとうございます!やってみましたところ、レター文章欄に挿入1のところ、すべて文章がつながってしまってしまいました。ちょっと仕様の説明が悪かったと反省しております。

コピー&ペーストする形で下に挿入される形でお願いしたいのです。

(挿入1と記されていた欄が消えて)

りんご

・・

みかん

すいか

(挿入2と記されていた欄が消えて)

イチゴ

オレンジ


(挿入10と記されていた欄が消えて)

お米

小麦

という感じです。

500文字制限にひっかかって細かい部分を削ったためこのようになってしまい、申し訳ありませんでした。

2010/06/22 15:28:48
id:SALINGER No.2

SALINGER回答回数3454ベストアンサー獲得回数9692010/06/22 13:59:33

ポイント10pt

takntさんが、一つのセルで回答したようなので、別のセルの方法です。

Sub Macro()
    Dim lastRow As Long
    Dim i As Long
    Dim key As String
    Dim rng As Range
    Dim r As Long
    Dim c As Long
    
    c = 1
    With Worksheets("レター")
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To lastRow
            If .Cells(i, 1).Value <> "" Then
                If r = 0 Then
                    Set rng = Worksheets("レター文章欄").Range("A:A").Find(.Cells(i, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not rng Is Nothing Then
                        r = rng.Row
                    End If
                Else
                    If .Cells(i, 1).Value = "終わり" Then
                        r = 0
                        c = 1
                    Else
                        Worksheets("レター文章欄").Cells(r, c).Value = .Cells(i, 1).Value
                        c = c + 1
                    End If
                End If
            End If
        Next i
    End With
End Sub
id:naranara19

SALINGERさん、いつもありがとうございます。早速のご回答ありがとうございます!

やってみましたところ、レター文章欄に挿入1のところ、すべて文章がつながってしまってしまいました。ちょっと仕様の説明が悪かったと反省しております。お二人ともそうですので、私の説明が悪いにつきます。

コピー&ペーストする形で下に挿入される形でお願いしたいのです。

(挿入1と記されていた欄が消えて)

りんご

・・

みかん

すいか

(挿入2と記されていた欄が消えて)

イチゴ

オレンジ


(挿入10と記されていた欄が消えて)

お米

小麦

という感じです。

これが挿入1等の位置が適当でもその場所にコピー⇒挿入される形でお願いしたいのです。

イチゴ

オレンジ

りんご

・・

みかん

すいか

(↑挿入1と2が逆で、他がない場合)

申し訳ありませんでした。

2010/06/22 15:31:06
id:SALINGER No.3

SALINGER回答回数3454ベストアンサー獲得回数9692010/06/22 15:40:59

ポイント70pt

なるほど縦に挿入でしたか。

Sub Macro()
    Dim lastRow As Long
    Dim i As Long
    Dim key As String
    Dim rng As Range
    Dim r As Long
    Dim c As Long
    
    With Worksheets("レター")
        lastRow = .Cells(Rows.Count, 1).End(xlUp).Row
        For i = 1 To lastRow
            If .Cells(i, 1).Value <> "" Then
                If r = 0 Then
                    Set rng = Worksheets("レター文章欄").Range("A:A").Find(.Cells(i, 1).Value, LookIn:=xlValues, lookat:=xlWhole)
                    If Not rng Is Nothing Then
                        r = rng.Row
                        Worksheets("レター文章欄").Rows(r).Delete
                    End If
                Else
                    If .Cells(i, 1).Value = "終わり" Then
                        r = 0
                        c = 0
                    Else
                        .Cells(i, 1).Copy
                        Worksheets("レター文章欄").Cells(r + c, 1).Insert Shift:=xlDown
                        c = c + 1
                    End If
                End If
            End If
        Next i
    End With
    Application.CutCopyMode = False
End Sub
id:naranara19

SALINGERさん、ありがとうございます!

「空白」がスルーされてしまいまして、縦にすべてつながってしまうようです。

空白のときでも、認識して行を空白で貼り付けられるようにお願いできますでしょうか?

最後お手数ですがお付き合いくださいませ。よろしくお願いいたします。

2010/06/22 16:12:30
id:taknt No.4

きゃづみぃ回答回数13538ベストアンサー獲得回数11982010/06/22 18:53:12

ポイント10pt
Sub Macro1()
    f = 0
    For b = 1 To Worksheets("レター").Range("A65536").End(xlUp).Row
        If Left(Worksheets("レター").Cells(b, "A"), 2) = "挿入" Then
            For g = 1 To Worksheets("レター文章欄").Range("A65536").End(xlUp).Row
                If Worksheets("レター").Cells(b, "A") = Worksheets("レター文章欄").Cells(g, "A") Then
                    e = g
                    Exit For
                End If
            Next g
            f = 1
            c = ""
        Else
            If f = 1 Then
                If Worksheets("レター").Cells(b, "A") = "終わり" Then
                    Worksheets("レター文章欄").Cells(e, "A") = ""
                    f = 0
                Else
                    Worksheets("レター文章欄").Cells(e, "A").Insert Shift:=xlDown
                    Worksheets("レター文章欄").Cells(e, "A") = Worksheets("レター").Cells(b, "A")
                    e = e + 1
                End If
            End If
        End If
   Next b
    
End Sub

挿入なんたらのセルの中身だけ消去しました。

id:naranara19

完璧でした!この度は不手際があったのに、最後までお付き合いいただき、誠にありがとうございました。今後ともよろしくお願い申し上げます!

2010/06/22 19:25:07
id:taknt No.5

きゃづみぃ回答回数13538ベストアンサー獲得回数11982010/06/22 18:48:52ここでベストアンサー

ポイント100pt
Sub Macro1()
    f = 0
    For b = 1 To Worksheets("レター").Range("A65536").End(xlUp).Row
        If Left(Worksheets("レター").Cells(b, "A"), 2) = "挿入" Then
            For g = 1 To Worksheets("レター文章欄").Range("A65536").End(xlUp).Row
                If Worksheets("レター").Cells(b, "A") = Worksheets("レター文章欄").Cells(g, "A") Then
                    e = g
                    Exit For
                End If
            Next g
            f = 1
            c = ""
        Else
            If f = 1 Then
                If Worksheets("レター").Cells(b, "A") = "終わり" Then
                    Worksheets("レター文章欄").Cells(e, "A").Delete Shift:=xlUp
                    f = 0
                Else
                    Worksheets("レター文章欄").Cells(e, "A").Insert Shift:=xlDown
                    Worksheets("レター文章欄").Cells(e, "A") = Worksheets("レター").Cells(b, "A")
                    e = e + 1
                End If
            End If
        End If
   Next b
    
End Sub
  • id:taknt
    >挿入1という言葉が消えて、その列に「レター」シートの2~5行迄の言葉が挿入されるようにしたい


    一つのセルの中に
    りんご ・・ みかん すいか
    とかいうように 空白などをはさんで入れればいいのですか?
  • id:taknt
    とりあえず 上記のコメントのようにして作成してみました。
  • id:SALINGER
    2回目の回答で
    挿入1というところが空白になって1行空ける場合は次のように変更してください。
     
    Worksheets("レター文章欄").Rows(r).Delete

    Worksheets("レター文章欄").Cells(r, 1).Value = ""
    r = r + 1
  • id:naranara19
    ありがとうございました。
    Worksheets("レター文章欄").Rows(r).Delete

    Worksheets("レター文章欄").Cells(r, 1).Value = ""
    r = r + 1
    に変えてみたのですが、↓の部分でエラーが出てしまいました。

    Set rng = Worksheets("レター文章欄").Range("A:A").Find(.Cells(i, 1).Value, LookIn:=xlValues, lookat:=xlWhole)


    いずれにせよありがとうございました。お二人の回答で締め切ります。他の方がご回答いただいてもポイントをつけられませんので、悪しからずご了承くださいませ。
  • id:SALINGER
    質問の例で私の環境ではエラーは出ないですが。
  • id:naranara19
    すみませんでした。
    またまたちょっと私の書き方もわかりづらかったかもしれません。

    エラーはでませんでした。間違ったコードがコピーされていました。私のミスでした。

    私がしたかったのは、

    ----------------------------------------------------------------
    「空白」がスルーされてしまいまして、縦にすべてつながってしまうようです。

    空白のときでも、認識して行を空白で貼り付けられるようにお願いできますでしょうか?
    ----------------------------------------------------------------
    でして、SALINGERさんのマクロを実行すると、

    レターシートに、

    挿入1
    りんご

    みかん
    終わり

    となって実行したときに、
    レター文章欄シートに

    りんご
    みかん

    と空白が詰められてしまうことでした。それを回避してほしかっただけなのです。
    今回の目的は達しましたので、締めたいと思います。
    いつも助かっておりますので、次回もよろしくお願いいたします。

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

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

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

絞り込み :
はてなココの「ともだち」を表示します。
回答リクエストを送信したユーザーはいません