アプリ版:「スタンプのみでお礼する」機能のリリースについて

ExcelのVBAで、列に入っているテキストを自動的にコピーし、同列内の次のセルにペーストするコードを組みたいのですが、上手くできません。

範囲内の初めのセルに入っているテキストをコピー後、
次のセルが空白ならば貼り付け、
空白でない(別のテキストが入っている)場合は
そのセルに入っているテキストを新たにコピーし、次のセルに貼り付け…
このような作業を繰り返し行いたいです。
(数が膨大すぎてオートフィルだと時間がかかるので自動化したいです)

【イメージ】
元データ     作りたいイメージ
A列         A列

りんご       りんご
          りんご
みかん       みかん
          みかん 
バナナ       バナナ
イチゴ       イチゴ
          イチゴ
          イチゴ
メロン       メロン
(以下繰りかえし)

こんな感じになるようにしたいです。

以下今使用しているコードです
(テキスト2つめまでは正しく動くのですが、テキスト3つ目からコピーしてくれなくなり、2つ目のテキストを吐き出してしまいます)

Sub コピーペースト()
Dim sourceRange As Range
Dim destinationRange As Range
Dim i As Integer
Dim copyText As String

' コピー元の範囲を選択
Set sourceRange = Range("C7:C291")

' コピー先の開始セルを選択
Set destinationRange = Range("C8:C292")

' テキストのコピーペーストを繰り返すループ
For i = 1 To sourceRange.Rows.Count
If destinationRange.Cells(i).Value = "" Then
' コピー先のセルが空白の場合、コピー元のセルをペースト
destinationRange.Cells(i).Value = sourceRange.Cells(i).Value
Else
' コピー先のセルにテキストが入っている場合、そのテキストをコピーして下のセルにペースト
copyText = destinationRange.Cells(i).Value
destinationRange.Cells(i + 1).Value = copyText
End If
Next i
End Sub

よろしくお願いします。

A 回答 (2件)

else文の箇所が不要かとおもいます。


以下のようにしてください。

Sub コピーペースト()
Dim sourceRange As Range
Dim destinationRange As Range
Dim i As Integer
Dim copyText As String

' コピー元の範囲を選択
Set sourceRange = Range("C7:C291")

' コピー先の開始セルを選択
Set destinationRange = Range("C8:C292")

' テキストのコピーペーストを繰り返すループ
For i = 1 To sourceRange.Rows.Count
If destinationRange.Cells(i).Value = "" Then
' コピー先のセルが空白の場合、コピー元のセルをペースト
destinationRange.Cells(i).Value = sourceRange.Cells(i).Value
End If
Next i
End Sub
    • good
    • 1
この回答へのお礼

ありがとうございます!
無事に解決できました!

お礼日時:2023/06/14 16:27

こんにちは



縦1列限定で良ければ、こんな感じでしょうか。

Sub test()
Dim v, c
Const scope = "C7:C291" ' ←対象セル範囲

v = ""
For Each c In Range(scope)
If c = Empty Then c.Value = v Else v = c.Value
Next c
End Sub
    • good
    • 1

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!