VBAで特定の文字を含む場合、カット＆ペーストしたい

お世話になります
VBAで特定の文字を含む場合、カット＆ペーストしたいです
画像のように&を含む文字の場合、その下のセルを次の&を含む文字までコピーし、
&を含む文字の右上のセルへペーストを２行目から最終行まで実施したいです。
（offsetを使って書くらしいのはわかったのですが）調べたのですがよくわかりません。。。
無知で大変恐縮ですが教えていただきたく願います。

No.3 回答者： 30246kiku 回答日時： 2015/07/26 08:26

解決されてましたらスルーしてください

以下のような考え方はどうでしょう

A列の空白セルを削除して
B列に & がある部分の抜き出し（行そのまま）
C列に & がない部分の抜き出し
C列先頭１つを削除して
空白行を削除して
A列を削除して

ループする記述がないので、ステップ実行で動きを見てください

なお、A列初めの内容に & があること、
※ 元々のデータ上でやるので注意してください


Public Sub Samp1()
　Application.ScreenUpdating = False
　With Range("A2", Cells(Rows.Count, "A").End(xlUp))
　　On Error Resume Next
　　.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
　　On Error GoTo 0
　　With .Offset(, 1)
　　　.FormulaR1C1 = "=IF(COUNTIF(RC1,""*&*""),RC1,"""")"
　　　.Value = .Value
　　End With
　　With .Offset(, 2)
　　　.FormulaR1C1 = "=IF(RC[-1]="""",RC1,"""")"
　　　.Value = .Value
　　　.Cells(1).Delete xlShiftUp
　　　.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
　　End With
　　.EntireColumn.Delete
　End With
　Application.ScreenUpdating = True
End Sub


※ 上記は & のあるセルが連続しないことが前提です
連続することがあれば、以下のようになるかと

Public Sub Samp2()
　Dim rng As Range

　Application.ScreenUpdating = False
　With Range("A2", Cells(Rows.Count, "A").End(xlUp))
　　On Error Resume Next
　　.SpecialCells(xlCellTypeBlanks).Delete xlShiftUp
　　On Error GoTo 0
　　With .Offset(, 1)
　　　.FormulaR1C1 = "=IF(COUNTIF(RC1,""*&*""),RC1,"""")"
　　　.Value = .Value
　　　Set rng = .SpecialCells(xlCellTypeBlanks).EntireRow
　　End With
　　With .Offset(, 2)
　　　.FormulaR1C1 = "=IF(RC[-1]="""",RC1,"""")"
　　　.Value = .Value
　　　.Cells(1).Delete xlShiftUp
　　　Intersect(rng _
　　　　, .SpecialCells(xlCellTypeBlanks).EntireRow).Delete
　　End With
　　.EntireColumn.Delete
　End With
　Application.ScreenUpdating = True
End Sub

No.2 回答者： WindFaller 回答日時： 2015/07/23 09:47

こんにちは。

マクロの典型的な練習問題のような題材ですね。
実行後では空白行は消えているということは、空白を削除する、というルールが加わっているようです。

'//
Sub AlignmentTest()
Dim Rng As Range
Dim c As Range
Dim stRng As Range
Dim lastRow As Long
Dim i As Long
Set Rng = Range("A2", Cells(Rows.Count, 1).End(xlUp))
Application.ScreenUpdating = False
For Each c In Rng
　If c.Value Like "#&*" Then
　 Set stRng = c.Offset(, 1)
　ElseIf c.Value <> "" Then
　 c.Copy stRng
　 c.ClearContents
　 Set stRng = c.Offset(, 1)
　End If
Next c
'空いている行を埋める
　lastRow = Cells(Rows.Count, 1).End(xlUp).Row
For i = lastRow To 2 Step -1
　If Cells(i, 1).Value = "" And Cells(i, 2).Value = "" Then
　　 Cells(i, 1).Resize(, 2).Delete　'2列分削除
　End If
Next i
Application.ScreenUpdating = True
End Sub
'///

No.1 回答者： tom04 回答日時： 2015/07/23 07:53

こんにちは！

カット＆ペーストではなく、Sheet2に表示するようにしてみました。
元データはSheet1にあるとします。
標準モジュールにしてみてください。

Sub Sample1()
Dim i As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
wS.Range("A:B").ClearContents
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, "A") <> "" Then
If InStr(.Cells(i, "A"), "&") > 0 Then
wS.Cells(Rows.Count, "B").End(xlUp).Offset(1, -1) = .Cells(i, "A")
Else
wS.Cells(Rows.Count, "B").End(xlUp).Offset(1) = .Cells(i, "A")
End If
End If
Next i
End With
End Sub

こんな感じではどうでしょうか？m(_ _)m