条件にあてはまる場合、行挿入＋値を移動させるマクロ

質問

Excel2003、WindowsXPを使用しています。

説明が分かり難いところがあるかもしれませんが、よろしくお願いいたします。

1.Ｃ列に値が入っていた場合、下に行を挿入。
2.挿入した行のＢ列に、Ｃ列に入っていた値を移動。
3.Ｄ列に値が入っていた場合、さらにその下に行を挿入。
4.挿入した行のＢ列に、Ｄ列に入っていた値を移動。
5.Ｅ列に値が入っていた場合、さらにその下に行を挿入。
6.挿入した行のＢ列に、Ｅ列に入っていた値を移動。

というように、Ｃ－Ｅ列に値が入っていた場合、下に行を挿入し、
挿入行にその値を移動させるマクロを教えてください。

（実行前）

　Ａ列　　　　　Ｂ列　　Ｃ列　　Ｄ列　　Ｅ列　　　Ｆ列
ああああ　　AAA　　BBB　　CCC　　DDD　　12222
うううう　　　 EEE 　 　 　 　　　　　　　　　　　　544
くくく　　　　　FFF　　GGG　　VVV 　　　　　　　8
すす　　　　 TTT　　 BBB　　　　　　　　　　　　4300

（実行後）
　Ａ列　　　　　Ｂ列　　　Ｃ列
ああああ　　AAA　　　12222
ああああ　　BBB　　　12222
ああああ　　CCC　　　12222
ああああ　　DDD　　　12222
うううう　　　 EEE　 　　544
くくく　　　　　FFF　　　 8
くくく　　　　　GGG　　　8
くくく　　　　　VVV　　 　8
すす　　　 　TTT　　　 4300
すす　　　 　BBB　　　4300

上記実行後のように、マクロで出来たら…と思っています。
どうぞよろしくお願いいたします。

回答No.9

hananoppo · ベストアンサー

ANo.8です。更にコンパクトにしてみました。

Sub Sample()
Dim rNum As Long
Dim iCnt As Integer

Application.ScreenUpdating = False
For rNum = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
iCnt = WorksheetFunction.CountA(Range("H" & rNum & ":M" & rNum))
If iCnt > 0 Then
Rows(rNum + 1).Resize(iCnt).Insert
Rows(rNum).Copy Rows(rNum + 1).Resize(iCnt)
Cells(rNum, 8).Resize(, iCnt).Copy
Cells(rNum + 1, 7).PasteSpecial Transpose:=True
End If
Next rNum
Columns("H:M").Delete
Application.ScreenUpdating = True
End Sub

お礼

ありがとうございます。

インフルエンザにかかっており、お返事が遅くなってしまい申し訳ありません。

ようやく先日会社へ行き試すことができました。
膨大なデータで、なかなかうまく動かなかったのですが、
hananoppoさんんに教えていただいたマクロをつかって処理を実施することが出来ました。
何度も教えてくださり、この度は本当にありがとうございました。

回答No.8

hananoppo

ANo.2です。補足の内容に対応しました。こちらでよいと思います。

Sub Sample()
Dim rNum As Long
Dim iCnt As Integer
Dim i As Integer

Application.ScreenUpdating = False
For rNum = Cells(Rows.Count, 1).End(xlUp).Row To 3 Step -1
iCnt = WorksheetFunction.CountA(Range("H" & rNum & ":M" & rNum))
If iCnt > 0 Then
Rows(rNum + 1 & ":" & rNum + iCnt).Insert
Rows(rNum).Copy Rows(rNum + 1 & ":" & rNum + iCnt)
For i = 1 To iCnt
Cells(rNum + i, 7).Value = Cells(rNum, 7 + i).Value
Next i
End If
Next rNum
Columns("H:M").Delete
Application.ScreenUpdating = True
End Sub

回答No.7

tom04

No.4です！
補足を読ませていただきました。

＞(1)処理を３行目から実施したいです。

＞(2)実際は、１行あたり、A～AC列まで情報が入っており、例題のB～E列に値する情報がG～M列に入っています。

とあるのは元データのA～F列・N～AC列はそのまますべて表示して、G～Mが前回のB～E列と考えれば良いわけですかね？
ということは元データのG～M列のデータはG列に1列だけに表示され、N～AC列はH～W列に表示されることになってしまいます。

一応そういうことだとして、
個人的にFor～Nextを使いたがる人間ですのでもう一度やってみました。

Sub test()
Dim i, j, k, L, M As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 3 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 7 To 13
If ws1.Cells(i, j) <> "" Then
M = ws2.Cells(Rows.Count, 1).End(xlUp).Row + 1
For k = 1 To 6
ws2.Cells(M, k) = ws1.Cells(i, k)
Next k
ws2.Cells(M, 7) = ws1.Cells(i, j)
For L = 14 To 29
ws2.Cells(M, L - 6) = ws1.Cells(i, L)
Next L
End If
Next j
Next i
End Sub

こんな感じではどうでしょうか？
今回もSheet1のデータをSheet2に表示するようにしています。

尚、大きく外している可能性が高いので別Sheetにコピー＆ペーストしてマクロを実行してみてください。

的外れならごめんなさいね。m(__)m

お礼

ありがとうございます。

インフルエンザにかかっており、お返事が遅くなってしまい申し訳ありません。

ようやく先日会社へ行き試すことができました。
膨大なデータで、なかなかうまく動かなかったのですが、
皆様に教えていただいたマクロをつかって処理を実施することが出来ました。
この度は本当にありがとうございました。

回答No.6

Wendy02

>(1)処理を３行目から実施したいです。
>(2)実際は、１行あたり、A～AC列まで情報が入っており、例題のB～E列に値する情報がG～M列に入っています。
　A　　 C
A列-間-AC列

そちらで、上手くいくかどうか、分かりません。理由は、飛び飛びのセルの場合を考慮していないからです。

'//
Sub TestMacro1R()
　Dim rng As Range
　Dim Ar As Variant, a As Variant
　Dim i As Long, j As Long, k As Long
　Dim Rw As Long, Col As Long

　Set rng = Range("A3", Cells(Rows.Count, 1).End(xlUp)).Resize(, 29) 'A--AC 29列
　'データチェック
　If rng.Cells.Count < 2 Then Exit Sub　'セル数が足りない場合
　Rw = rng.Rows.Count: Col = rng.Columns.Count
　Ar = rng.Value
　rng.ClearContents
　j = 1
　k = 1 '書き出しの初期値
　Application.ScreenUpdating = False
　With rng
　For i = 1 To Rw
　　j = 7 'G列から
　　Do
　　　a = Ar(i, j)
　　　If a <> "" Then
　　　　.Cells(k, 2).Value = a
　　　　.Cells(k, 1).Value = Ar(i, 1)
　　　　.Cells(k, 3).Value = Ar(i, Col)
　　　　k = k + 1
　　　End If
　　　j = j + 1
　　Loop Until j > 13　'M列まで
　Next i
　End With
　Application.ScreenUpdating = False
End Sub

お礼

ありがとうございます。

インフルエンザにかかっており、お返事が遅くなってしまい申し訳ありません。

ようやく先日会社へ行き試すことができました。
とびとびに空白セルがあり、なかなかうまくうごかなかったのですが、
皆様に教えていただいたマクロをつかって処理を実施することが出来ました。
この度は本当にありがとうございました。

回答No.5

KURUMITO

ご質問と同じ操作をさせるためのマクロでしたら次のようにしてはいかがでしょう。

Sub 並び替え()
Dim RowPos As Integer
Dim RowPos1 As Integer
Dim ColPs As Integer
Dim i As Integer
RowPos = 0
ColPos = 2
i = 0
Do
RowPos = RowPos + 1
If Cells(RowPos, 6) = "" Then
Exit Sub
End If
Do
ColPos = ColPos + 1
If Cells(RowPos, 3) = "" Then
Cells(RowPos, 3) = Cells(RowPos, 6)
Cells(RowPos, 6) = ""
RowPos = RowPos + 1
End If
If Cells(RowPos, ColPos) <> "" And Cells(RowPos, 6) <> "" Then
i = i + 1
RowPos1 = RowPos + i
Rows(RowPos1).Insert Shift:=xlShiftDown
Cells(RowPos1, 1) = Cells(RowPos, 1)
Cells(RowPos1, 2) = Cells(RowPos, ColPos)
Cells(RowPos1, 3) = Cells(RowPos, 6)
End If
Loop Until ColPos = 5
Cells(RowPos, 3) = Cells(RowPos, 6)
Range(Cells(RowPos, 4), Cells(RowPos, 6)) = ""
RowPos = RowPos1
ColPos = 2
i = 0
Loop Until Cells(RowPos + 1, 1) = ""
End Sub

補足

ありがとうございます。
さっそく試してみたところ、できました！
ありがとうございました。

申し訳ないのですが、もう一つ教えて頂けませんでしょうか？

後出しで申し訳ないのですが、実際の表のフォーマットは、例で挙げたものより列数や行数が多く、一番上の行は空白行です。
また、２行目はタイトル行になっています。

(1)処理を３行目から実施したいです。

(2)実際は、１行あたり、A～AC列まで情報が入っており、例題のB～E列に値する情報がG～M列に入っています。

教えて頂いたマクロを修正しようと思い、にらめっこしてみたのですが、
知識が乏しく、(1)と(2)なかなかうまく出来ませんでした。
(1)と(2)の状態で処理ができるようにするには、教えて頂いたマクロのどの部分を変更すれば良いのでしょうか？

お忙しいところ申し訳ありませんが、よろしくお願いいたします。

回答No.4

tom04

こんにちは！
横からお邪魔します。

一例です。
No．3さんと似たような方法になってしまいますが・・・
sheet1のデータをsheet2に表示するようにしてみました。

Sub test()
Dim i, j As Long
Dim ws1, ws2 As Worksheet
Set ws1 = Worksheets("sheet1")
Set ws2 = Worksheets("sheet2")
For i = 1 To ws1.Cells(Rows.Count, 1).End(xlUp).Row
For j = 2 To 5
If ws1.Cells(i, j) <> "" Then
With ws2.Cells(Rows.Count, 1).End(xlUp).Offset(1)
.Value = ws1.Cells(i, 1)
.Offset(, 1) = ws1.Cells(i, j)
.Offset(, 2) = ws1.Cells(i, 6)
End With
End If
Next j
Next i
End Sub

※　Offsetで表示するようにしていますで、1行目にはデータが表示されないと思います。

的外れならごめんなさいね。m(__)m

補足

ありがとうございます。
さっそく試してみたところ、できました！
ありがとうございました。
Sheet２に出すという方法もあるのですね・・・。改めて、もっと勉強しようと思いました。

申し訳ないのですが、もう一つ教えて頂けませんでしょうか？

後出しで申し訳ないのですが、実際の表のフォーマットは、例で挙げたものより列数や行数が多く、一番上の行は空白行です。
また、２行目はタイトル行になっています。

(1)処理を３行目から実施したいです。

(2)実際は、１行あたり、A～AC列まで情報が入っており、例題のB～E列に値する情報がG～M列に入っています。

教えて頂いたマクロを修正しようと思い、にらめっこしてみたのですが、
知識が乏しく、(1)と(2)なかなかうまく出来ませんでした。
(1)と(2)の状態で処理ができるようにするには、教えて頂いたマクロのどの部分を変更すれば良いのでしょうか？

お忙しいところ申し訳ありませんが、よろしくお願いいたします。

回答No.3

luka3

私は元のシートを直接いじるのはあまりやりたくないので
新規ブックを作成してそちらにデータを写します。

Sub Test()
　Dim bk As Workbook
　Dim yy As Integer, y As Integer, x As Integer

　Set bk = Workbooks.Add
　yy = 1
　For y = 1 To ThisWorkbook.ActiveSheet.UsedRange.End(xlDown).Row
　　For x = 2 To 5
　　　If ThisWorkbook.ActiveSheet.Cells(y, x).Value <> "" Then
　　　　bk.Worksheets(1).Cells(yy, 1).Value = ThisWorkbook.ActiveSheet.Cells(y, 1).Value
　　　　bk.Worksheets(1).Cells(yy, 2).Value = ThisWorkbook.ActiveSheet.Cells(y, x).Value
　　　　bk.Worksheets(1).Cells(yy, 3).Value = ThisWorkbook.ActiveSheet.Cells(y, 6).Value
　　　　yy = yy + 1
　　　End If
　　Next
　Next
End Sub

補足

ありがとうございます。
さっそく試してみたところ、できました！
新しいBOOKに処理が出せるんですね。すごいです。
ありがとうございました。

申し訳ないのですが、もう一つ教えて頂けませんでしょうか？

後出しで申し訳ないのですが、実際の表のフォーマットは、例で挙げたものより列数や行数が多く、一番上の行は空白行です。
また、２行目はタイトル行になっています。

(1)処理を３行目から実施したいです。

(2)実際は、１行あたり、A～AC列まで情報が入っており、例題のB～E列に値する情報がG～M列に入っています。

教えて頂いたマクロを修正しようと思い、にらめっこしてみたのですが、
知識が乏しく、(1)と(2)なかなかうまく出来ませんでした。
(1)と(2)の状態で処理ができるようにするには、教えて頂いたマクロのどの部分を変更すれば良いのでしょうか？

お忙しいところ申し訳ありませんが、よろしくお願いいたします。

回答No.2

hananoppo

こんな感じで如何でしょう。

Sub Sample()
Dim rNum As Long
Dim iCnt As Integer
Dim i As Integer

Application.ScreenUpdating = False
For rNum = Cells(Rows.Count, 1).End(xlUp).Row To 1 Step -1
iCnt = Application.WorksheetFunction.CountA(Range("C" & rNum & ":E" & rNum))
If iCnt > 0 Then
Rows(rNum + 1 & ":" & rNum + iCnt).Insert
For i = 1 To iCnt
Cells(rNum + i, 1).Value = Cells(rNum, 1).Value
Cells(rNum + i, 2).Value = Cells(rNum, 2 + i).Value
Cells(rNum + i, 3).Value = Cells(rNum, 6).Value
Next i
End If
Cells(rNum, 3).Value = Cells(rNum, 6).Value
Range("D" & rNum & ":F" & rNum).ClearContents
Next rNum
Application.ScreenUpdating = True
End Sub

補足

ありがとうございます。
さっそく試してみたところ、できました！
ありがとうございました。

申し訳ないのですが、もう一つ教えて頂けませんでしょうか？

後出しで申し訳ないのですが、実際の表のフォーマットは、例で挙げたものより列数や行数が多く、一番上の行は空白行です。
また、２行目はタイトル行になっています。

(1)処理を３行目から実施したいです。

(2)実際は、１行あたり、A～AC列まで情報が入っており、例題のB～E列に値する情報がG～M列に入っています。

教えて頂いたマクロを修正しようと思い、にらめっこしてみたのですが、
知識が乏しく、(1)と(2)なかなかうまく出来ませんでした。
(1)と(2)の状態で処理ができるようにするには、教えて頂いたマクロのどの部分を変更すれば良いのでしょうか？

お忙しいところ申し訳ありませんが、よろしくお願いいたします。

回答No.1

Wendy02

挿入など必要ないと思います。単に、並べ替えすればよいのでは？

'標準モジュールがベター
Sub TestMacro1()
　Dim rng As Range
　Dim Ar As Variant, a As Variant
　Dim i As Long, j As Long, k As Long
　Dim Rw As Long, Col As Long

　Set rng = Range("A1").CurrentRegion
　'データチェック
　If rng.Cells.Count < 2 Then Exit Sub
　If rng.Columns.Count < 4 Then Exit Sub
　Rw = rng.Rows.Count: Col = rng.Columns.Count
　Ar = rng.Value
　rng.ClearContents
　j = 1
　k = 1 '書き出しの初期値
　Application.ScreenUpdating = False
　For i = 1 To Rw
　　j = 2
　　Do
　　　a = Ar(i, j)
　　　If Trim(a) <> "" Then
　　　　Cells(k, 2).Value = a
　　　　Cells(k, 1).Value = Ar(i, 1)
　　　　Cells(k, 3).Value = Ar(i, Col)
　　　　k = k + 1
　　　End If
　　　j = j + 1
　　Loop Until j > (Col - 1)
　Next i
　Application.ScreenUpdating = False
End Sub

補足

ありがとうございます。
さっそく試してみたところ、できました！
ありがとうございました。

申し訳ないのですが、もう一つ教えて頂けませんでしょうか？

後出しで申し訳ないのですが、実際の表のフォーマットは、例で挙げたものより列数や行数が多く、一番上の行は空白行です。
また、２行目はタイトル行になっています。

(1)処理を３行目から実施したいです。

(2)実際は、１行あたり、A～AC列まで情報が入っており、例題のB～E列に値する情報がG～M列に入っています。

教えて頂いたマクロを修正しようと思い、にらめっこしてみたのですが、
知識が乏しく、(1)と(2)なかなかうまく出来ませんでした。
(1)と(2)の状態で処理ができるようにするには、教えて頂いたマクロのどの部分を変更すれば良いのでしょうか？

お忙しいところ申し訳ありませんが、よろしくお願いいたします。