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

エクセル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などがくるのかは各シートとも、毎回変わります。

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

●質問者: naranara19
●カテゴリ:コンピュータ 科学・統計資料
✍キーワード:24 VBA うご お勧め すいか
○ 状態 :終了
└ 回答数 : 5/5件

▽最新の回答へ

1 ● きゃづみぃ
●10ポイント
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
◎質問者からの返答

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

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

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

りんご

・・

みかん

すいか

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

イチゴ

オレンジ


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

お米

小麦

という感じです。

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


2 ● SALINGER
●10ポイント

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
◎質問者からの返答

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

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

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

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

りんご

・・

みかん

すいか

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

イチゴ

オレンジ


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

お米

小麦

という感じです。

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

イチゴ

オレンジ

りんご

・・

みかん

すいか

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

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


3 ● SALINGER
●70ポイント

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

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
◎質問者からの返答

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

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

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

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


4 ● きゃづみぃ
●10ポイント
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

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

◎質問者からの返答

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


5 ● きゃづみぃ
●100ポイント ベストアンサー
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
関連質問


●質問をもっと探す●



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