VBAにてセルの値を移動させる方法を教えてください。

質問

VBAを使用しEXCELのセルの値を移動させたいのですが、たとえば下記のように●と▲で構成された同じワークシート内のセルの集合に対し(1)の集合を(2)の集合を維持したまま(2)に移動させたいのです。

　　　　　(1)　　　　　　　　　　　　(2)
ＡＢＣＤＥＦＧＨＩ　　　　ＪＫＬＭＮＯＰＱＲ
1▲●　　　　　　　　　　　●
2●　　　　　　　　　　　　▲●
3▲　●　　　　　　　　　　▲▲●
4●●●●　　　　　　　　　●●
5▲▲▲●●　　　　　　　　●▲
6▲●　　　　　　　　　　　●●▲

移動後
　　　　(2)（(1)+(2)）
ＪＫＬＭＮＯＰＱＲ
1●▲●
2▲●●
3▲▲●▲●
4●●●●●●
5●▲▲▲▲●●
6●●▲▲●

(1)の異動元のＢ3の空白は移動後には左に詰めるようにし、移動後の内容でセル列Ｒを越える値は切り捨てるようにもしたいのです。こんな形でのマクロをご教授いただきたいのですが、よろしくお願いいたします。

回答No.3

_Kyle · ベストアンサー

#1です。

>移動先の行に全く何も入力されていない空白があると…
なんか（いろいろと）変なことしてましたね。
すみません。修正しました。

>何行目までとかも指定はできますか？
下記コードで999となっている部分を書き換えてください。

なお、#1のコードで「9」を直接埋め込んでましたが、
それだとああいう書き方をした意味がありませんでした。
その辺も直しました。

もし遅すぎるようでしたらまた直しますので補足してください。

'---------------↓　ココカラ　↓---------------
Sub Sample0906112()
　Dim myRng1 As Range
　Dim myRng2 As Range
　Dim i　　　As Long
　Dim j　　　As Long
　Dim k　　　As Long
　Set myRng1 = Range("A:I")　'A:I列を移す
　Set myRng2 = Range("J:R")　'J:R列に移す
　For i = 1 To 999 '1行目から999行目まで
　　For j = myRng2.Columns.Count To 1 Step -1
　　　If myRng2(i, j).Value <> "" Then Exit For
　　Next j
　　j = j + 1
　　For k = 1 To myRng1.Columns.Count
　　　If j > myRng2.Columns.Count Then Exit For
　　　If myRng1(i, k).Value <> "" Then
　　　　myRng2(i, j).Value = myRng1(i, k).Value
　　　　j = j + 1
　　　End If
　　Next k
　　myRng1.Rows(i).ClearContents
　Next i
End Sub
'---------------↑　ココマデ　↑---------------

お礼

ありがとうございました！！私が思っていた通りに動作しました。初心者の私には全く思いつきようのないマクロです。本当にありがとうございました。

回答No.4

hige_082

一例です

Sub test()
Dim i As Long, ii As Long
'-----------------------------------------
ii = 100 '←処理最終行を指定指定してください
'-----------------------------------------
For i = 1 To ii
If Range("s" & i).End(xlToLeft).Column < 10 Then
Cells(i, 1).Resize(1, 9).Copy Range("j" & i).Resize(1, 9)
Else
Cells(i, 1).Resize(1, 9).Copy Range("s" & i).End(xlToLeft).Offset(, 1).Resize(1, 9)
End If
Next i
Columns("S:AA").ClearContents
If WorksheetFunction.CountBlank(Range("J1:R" & ii)) = 0 Then Exit Sub
Range("J1:R" & ii).SpecialCells(xlCellTypeBlanks).Delete Shift:=xlToLeft
End Sub

参考まで

お礼

ご親切にありがとうございます。こちらも試して勉強させていただきます。

回答No.2

fujillin

単純に左から見て行って、値が空白でなければコピーしてあげればよいだけではないのかな。（意味が違っていたら無視願います）

こんな感じ？（あとは適当に修正してください）
Sub test()
Dim rw As Long, col As Long, ctmp As Long

For rw = 1 To 6
　ctmp = Cells(rw, Columns.Count).End(xlToLeft).Column + 1
　If ctmp < 10 Then ctmp = 10
　For col = 1 To 9
　If Cells(rw, col).Value <> "" Then
　　　Cells(rw, ctmp).Value = Cells(rw, col).Value
　　　ctmp = ctmp + 1
　　End If
　Next col
Next rw
End Sub

お礼

ご親切にありがとうございます。こちらも試して勉強させていただきます。

回答No.1

_Kyle

とりあえずこんな感じでいかがでしょうか。

●動作の概要
　1行目から(A列の)最終行までの各行について、
　A:I列の値をJ:R列のデータの後方に順序を維持して移動する。
　・J:R列のデータはそのまま維持する
　・A:I列について空白がある場合は無視する
　・S列以降は使用しない

'---------------↓　ココカラ　↓---------------
Sub Sample090611()
　Dim myAry1 As Variant
　Dim myAry2 As Variant
　Dim i　　　As Long
　Dim j　　　As Long
　Dim k　　　As Long
　For i = 1 To Cells(Rows.Count, "A").End(xlUp).Row
　　myAry1 = Range("A:I").Rows(i).Value
　　Range("A:I").Rows(i).ClearContents
　　myAry2 = Range("J:R").Rows(i).Value
　　For j = 9 To 1 Step -1
　　　If myAry2(1, j) <> "" Then
　　　　j = j + 1
　　　　Exit For
　　　End If
　　Next j
　　For k = 1 To 9
　　　If myAry1(1, k) <> "" Then
　　　　myAry2(1, j) = myAry1(1, k)
　　　　If j = 9 Then
　　　　　Exit For
　　　　Else
　　　　　j = j + 1
　　　　End If
　　　End If
　　Next k
　　Range("J:R").Rows(i).Value = myAry2
　Next i
End Sub
'---------------↑　ココマデ　↑---------------

Excel2003で動作確認。

補足

ありがとうございます。移動元、移動先の行に全く何も入力されていない空白があるとその下の行からは移動しないので『インデックスが有効な範囲にありません』と表示しますが、移動元、移動先の行が空白でも移動可能に出来ますか？後、1行目から(A列の)最終行まででなくて何行目までとかも指定はできますか？もし可能でしたらお教えいただきたいのです。ご無理を言いますがよろしくお願いいたします。