Excelで特定文字が含まれる行の別のセルをずらす

質問

添付画像にあるように、2つの列に記号とキーワードが入力されており、上から順番に検索し、キーワード列に特定文字（この場合”りんご”）を含むセルがある場合、記号列のみを下に順番にずらしていきたいと思っています。

行数が1万行くらいある為、マクロなどで実現したいです。

よろしくお願いいたします。

回答No.10

kkkkkm

No9です、
実行するたびに記号列で空白になった部分もふくめてずれていくので、記号列は空白セルを無視するように変更しました。

Sub Example()

Dim MyArrayB As Variant, MyArrayC As Variant, Myarr As Variant
Dim SearchStr As String
Dim i As Long, j As Long, k As Long, l As Long

MyArrayB = Range(Cells(3, "B"), Cells(Rows.Count, "B").End(xlUp))
MyArrayC = Range(Cells(3, "C"), Cells(Rows.Count, "C").End(xlUp))
SearchStr = "りんご"
j = 1: k = 0
l = WorksheetFunction.CountIf(Range(Cells(3, "C"), Cells(Rows.Count, "C").End(xlUp)), SearchStr)
ReDim Myarr(UBound(MyArrayC) + l, 1)
For i = 1 To UBound(Myarr)
If MyArrayB(j, 1) <> "" Then
If UBound(MyArrayC) >= i Then
If MyArrayC(i, 1) <> SearchStr Then
Myarr(k, 0) = MyArrayB(j, 1)
j = j + 1
If j > UBound(MyArrayB) Then
j = 1
End If
Else
Myarr(k, 0) = ""
End If
Else
Myarr(k, 0) = MyArrayB(j, 1)
j = j + 1
If j > UBound(MyArrayB) Then
j = 1
End If
End If
k = k + 1
Else
j = j + 1
i = i - 1
End If
Next
Range(Cells(3, "B"), Cells(UBound(Myarr) + 3, "B")) = Myarr
End Sub

回答No.9

kkkkkm

No8です
列をA列B列と間違えてました。B列とC列に変更しました。

Sub Example()

Dim MyArrayB As Variant, MyArrayC As Variant, Myarr As Variant
Dim SearchStr As String
Dim i As Long, j As Long, k As Long, l As Long

MyArrayB = Range(Cells(3, "B"), Cells(Rows.Count, "B").End(xlUp))
MyArrayC = Range(Cells(3, "C"), Cells(Rows.Count, "C").End(xlUp))
SearchStr = "りんご"
j = 1: k = 0
l = WorksheetFunction.CountIf(Range(Cells(3, "C"), Cells(Rows.Count, "C").End(xlUp)), SearchStr)
ReDim Myarr(UBound(MyArrayC) + l, 1)
For i = 1 To UBound(Myarr)
If UBound(MyArrayC) >= i Then
If MyArrayC(i, 1) <> SearchStr Then
Myarr(k, 0) = MyArrayB(j, 1)
j = j + 1
If j > UBound(MyArrayB) Then
j = 1
End If
Else
Myarr(k, 0) = ""
End If
Else
Myarr(k, 0) = MyArrayB(j, 1)
j = j + 1
If j > UBound(MyArrayB) Then
j = 1
End If
End If
k = k + 1
Next
Range(Cells(3, "B"), Cells(UBound(Myarr) + 3, "B")) = Myarr
End Sub

回答No.8

kkkkkm

キーワードと記号が同数だと例示通りになりますが、記号が少ない場合があれば、一番上の記号に戻ってふり直します。記号が多い場合は、たとえば例示に画像の下に記号だけが「ちつけと」まであるとしても、例示の画像の状態(「た」で終わる)になるようになっています。

Sub Example()

Dim MyArrayA As Variant, MyArrayB As Variant, Myarr As Variant
Dim SearchStr As String
Dim i As Long, j As Long, k As Long, l As Long

MyArrayA = Range(Cells(3, "A"), Cells(Rows.Count, "A").End(xlUp))
MyArrayB = Range(Cells(3, "B"), Cells(Rows.Count, "B").End(xlUp))
SearchStr = "りんご"
j = 1: k = 0
l = WorksheetFunction.CountIf(Range(Cells(3, "B"), Cells(Rows.Count, "B").End(xlUp)), SearchStr)
ReDim Myarr(UBound(MyArrayB) + l, 1)
For i = 1 To UBound(Myarr)
If UBound(MyArrayB) >= i Then
If MyArrayB(i, 1) <> SearchStr Then
Myarr(k, 0) = MyArrayA(j, 1)
j = j + 1
If j > UBound(MyArrayA) Then
j = 1
End If
Else
Myarr(k, 0) = ""
End If
Else
Myarr(k, 0) = MyArrayA(j, 1)
j = j + 1
If j > UBound(MyArrayA) Then
j = 1
End If
End If
k = k + 1
Next
Range(Cells(3, "A"), Cells(UBound(Myarr) + 3, "A")) = Myarr
End Sub

回答No.7

imogasi

#6です。ほかにも下記のようなロジックでもできる。
考えれば、他にも方法があると思う。
言いたいことは、ここに質問する前に、自分でこのロジックという部分を考えること。
この問題に対しては、ロジックは手が付けられないほどの複雑なものではないだろうと思う。
Sub test02()
lr = Worksheets("Sheet1").Range("a10000").End(xlUp).Row
j = 2
For i = 2 To lr
Worksheets("Sheet3").Cells(i, "b") = Worksheets("Sheet1").Cells(i, "B")
If Worksheets("Sheet1").Cells(i, "B") = "りんご" Then
'--B列がりんごなら、A列に何もセットしない
Else
'--B列がりんごでないなら、A列にJ番目のA列を取ってきてセット
Worksheets("Sheet3").Cells(i, "A") = Worksheets("Sheet1").Cells(j, "A")
j = j + 1 'Sheet1のA列１行下へ
End If
Next i
'---A列残りセット
For i = lr + 1 To lr + (lr - j + 1)
Worksheets("Sheet3").Cells(i, "A") = Worksheets("Sheet1").Cells(j, "A")
j = j + 1
Next i
End Sub
文章で言えば、「B列が「りんご」なら記号（同行）A列）を振らず。「りんご」でなければ、A列の上から１つづつ取ってA列にセットしていく。直前までにどこまでA列のデータを取ったか、のポインターを１つ使えばしまい。

回答No.6

imogasi

まずVBAの質問であることを早いうちに（表題で）明記せよ。
ーー
今回は画像の文字がみえるが、
このやりたいことのロジックを文章で書いてみること。そうすると、内容が明確になる。
たとえば文章にしたら、りんごの行が現れたら、A列だけを、その次行以下を１行分下方向にシフトする。
キーワード列は処理後も（内容、順序とも）変わらないようだね。
ーー
Sheet1をSheet2にそっくりコピー貼り付けしておいて
標準モジュールに（貼りつけたSheet2のデータに対し）
Sub test01()
i = 2
lr1 = Range("a10000").End(xlUp).Row
Do While i <= lr1
If Cells(i, "B") = "りんご" Then
lr = Range("a1000").End(xlUp).Row
Range(Cells(i, "A"), Cells(lr, "A")).Cut (Cells(i + 1, "A"))
End If
i = i + 1
Loop
End Sub
＝＝
例データ
質問の通り
Sheet1のA1:B１９
記号 キーワード
あ みかん
い りんご
う りんご
え みかん
お みかん
か みかん
き りんご
く きゅうり
け なす
こ みかん
さ りんご
し りんご
す りんご
せ りんご
そ とまと
た とまと
ち とまと
つ うめ

結果データ　Sheet2
記号 キーワード
あ みかん
りんご
りんご
い みかん
う みかん
え みかん
りんご
お きゅうり
か なす
き みかん
りんご
りんご
りんご
りんご
く とまと
け とまと
こ とまと
さ うめ
し
す
せ
そ
た
ち
つ
ーー
今までにない、ちょっと変わった問題だがこれでよいのかな。

回答No.5

ushi2015

こんにちは、No2、No4です。
一万行あると遅くてダメでした。
速くするとNo3さんのコードに似通ってしまうのですが、
Sub test3()
　　Dim r As Range
　　Dim d As Variant
　　Dim t As Variant
　　Dim i As Long
　　Dim j As Long
　　Dim k As Long
　　Set r = Range("C3", Range("C" & Rows.Count).End(xlUp))
　　With r.Offset(, 1)
　　　　.Formula = "=IFERROR(FIND(""りんご"",C3,1),"""")"
　　　　.Value = .Value
　　　　j = WorksheetFunction.CountA(.Cells)
　　　　d = r.Offset(, -1).Value
　　　　t = .Resize(.Rows.Count + j).Value
　　　　k = 1
　　　　For i = 1 To UBound(t, 1)
　　　　　　If t(i, 1) = "" Then
　　　　　　　　t(i, 1) = d(k, 1)
　　　　　　　　k = k + 1
　　　　　　Else
　　　　　　　　t(i, 1) = ""
　　　　　　End If
　　　　Next
　　　　.ClearContents
　　　　.Offset(, -2).Resize(UBound(t, 1)).Value = t
　　End With
End Sub

回答No.4

ushi2015

こんにちは、No2です。
指摘されて勘違いに気付きました。
Sub test2()
　　Dim r As Range
　　Dim i As Long
　　Dim j As Long
　　Set r = Range("C3", Range("C" & Rows.Count).End(xlUp))
　　On Error GoTo Err_Line
　　With r.Offset(, 1)
　　　　.Formula = "=IFERROR(FIND(""りんご"",C3,1),"""")"
　　　　.Value = .Value
　　　　j = .SpecialCells(xlCellTypeConstants).Areas.Count
　　　　Application.ScreenUpdating = False
　　　　For i = 1 To j
　　　　　　.SpecialCells(xlCellTypeConstants).Areas(i) _
　　　　　　 .Offset(, -2).Insert xlShiftDown
　　　　Next
　　　　.ClearContents
　　　　Application.ScreenUpdating = True
　　End With
　　Exit Sub
Err_Line:
　　MsgBox Err.Description
End Sub
に差し替えて下さい。

No3さんのも「キーワード列に特定文字（この場合”りんご”）を含むセル」
含むという前提が部分一致という質問なら期待した結果になりませんね。

回答No.3

chie65536（@chie65535）

以下のようなマクロでどうでしょう？

Findやセルの移動を行なわないので、１万行あっても１秒未満で終わります。

Sub Macro1()
Dim i As Integer
Dim j As Integer
Dim l As Integer
Dim c As Integer
Dim s As Integer
Columns("C:C").Insert Shift:=xlToRight
s = Range("B3").Row
j = s
l = Range("B65536").End(xlUp).Row
c = Range("B3").Column
Cells(2, c + 1).Value = Cells(2, c).Value
For i = s To l
If Cells(j, c + 2).Value = "りんご" Then
j = j + 1
i = i - 1
Else
Cells(j, c + 1).Value = Cells(i, c).Value
j = j + 1
End If
Next
Columns("B:B").EntireColumn.Delete
End Sub

蛇足ですがANo.1のマクロは「永久に終了しない」ので実行してはいけません。

またANo.2のマクロは、当方のEXCEL2003では、期待した結果になりませんでした。

回答No.2

ushi2015

こんにちは
こういう事ですか？
Sub test1()
　　Dim r As Range
　　Dim i As Long
　　Dim j As Long
　　Set r = Range("C3", Range("C" & Rows.Count).End(xlUp))
　　On Error GoTo Err_Line
　　With r.Offset(, 1)
　　　　.Formula = "=IFERROR(FIND(""りんご"",C3,1),"""")"
　　　　.Value = .Value
　　　　j = .SpecialCells(xlCellTypeConstants).Areas.Count
　　　　Application.ScreenUpdating = False
　　　　For i = j To 1 Step -1
　　　　　　.SpecialCells(xlCellTypeConstants).Areas(i) _
　　　　　　 .Offset(, -2).Insert xlShiftDown
　　　　Next
　　　　.ClearContents
　　　　Application.ScreenUpdating = True
　　End With
　　Exit Sub
Err_Line:
　　MsgBox Err.Description
End Sub

回答No.1

shintaro-2

エクセルにはマクロの記録という機能が有りますので、
ご自分でまずは操作を記録してみてください（セルを相対参照にすること）

キーワードが固定ですが、
大体こんな感じです。
Sub Macro2()
'
' Macro2 　行シフト
'

'
Do
Unitil ActiveCell = ""
Cells.Find(What:="りんご", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
, MatchByte:=False, SearchFormat:=False).Activate
ActiveCell.Offset(0, -1).Range("A1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
ActiveCell.Offset(0, 1).Range("A1").Select
Loop

End Sub