Excel マクロ抽出、別シートに張り付け

質問

Excelマクロについて質問です。
(1)特定の行の抽出方法
(2)抽出した複数の行を別シートに貼付ける方法
(3)　例　Cells(1,1)=Cells(2,1)=1 And Cells(1,3)=Cells(2,3)=1 And Cells(1,6)=Cells(2,6)=0の時のように、i=1,3,6でCells(k,i)=Cells(k+1,i)が成り立ち、Cells(k,i)の行だけを抜き出すコードの書き方を教えていただけますでしょうか？
宜しくお願い致します。

回答No.5

mindatg

No2への補足に気付いていませんでした
No3をその条件で完成させました。

'簡易版------------------------------------------------------
Sub 次の行と一致なら指定シートにコピー()
Dim k as Integer
Dim RowCnt as Integer
Dim stSheetName as String

stSheetName = "Sheet2" ' ←変更してね
RowCnt = 1000 ' ←変更してね

For k = 1 to RowCnt

　If Cells(k,1) = Cells(k+1,1) AND _
　　 Cells(k,3) = Cells(k+1,3) AND _
　　Cells(k,6) = Cells(k+1,6) THEN

' 条件に一致した行をコピー
　Rows(k).Copy

' 指定シートに上から詰めて貼り付け
　Worksheets(stSheetName).Rows(Worksheets(stSheetName).UsedRange.SpecialCells(xlLastCell).Row + 1).PasteSpecial

　End If
Next k
End Sub
'簡易版ここまで------------------------------------------------------

' ちょっと改造版-----------------------------------------------------
Sub 次の行と一致なら指定シートにコピー２()
Dim k as Integer
Dim RowCnt as Integer
Dim stSheetName as String
Dim objWs As Worksheet

' 貼り付け先のシート名を手入力で指定
stSheetName = InputBox("貼り付け先のシート名を入力")
' 空欄、シート名が存在しない場合は処理しない
If Len(stSheetName) = 0 Then Exit Sub
For Each objWs In Worksheets
　 If objWs.Name = stSheetName Then GoTo FindSheet
Next objWs
Exit Sub

FindSheet:
' ループ回数を行末に設定
RowCnt = ActiveSheet.UsedRange.SpecialCells(xlLastCell).Row

For k = 1 to RowCnt

　If Cells(k,1) = Cells(k+1,1) AND _
　　 Cells(k,3) = Cells(k+1,3) AND _
　　Cells(k,6) = Cells(k+1,6) THEN

' 条件に一致した行をコピー
　Rows(k).Copy

' 指定シートに上から詰めて貼り付け
　Worksheets(stSheetName).Rows(Worksheets(stSheetName).UsedRange.SpecialCells(xlLastCell).Row + 1).PasteSpecial

　End If
Next k

' 処理完了のお知らせ
MsgBox("処理が終了しました。")
End Sub
' ちょっと改造版ここまで-----------------------------------------------------

列の指定、数万行・数十列の時間のかかるケース、貼り付け方法など改造の余地は山ほどありますが
とりあえずはこれで大丈夫じゃないでしょうか

補足

重複が1列だけを見る場合は以下のプログラムでできました。
３列ある場合はどうするのでしょうか？
Sub 重複削除()

Dim i As Double, j As Double
i = 3

Do Until Cells(i, 1) = ""
j = i + 1

Do Until Cells(j, 1) = ""
If Cells(i, 1) = Cells(j, 1) Then
Rows(j).Delete
j = j - 1
End If
j = j + 1
Loop

i = i + 1
Loop
End Sub

回答No.4

tom04

こんばんは！

横からお邪魔します。
他の方への補足を拝見して・・・

標準モジュールに↓のコードをコピー＆ペーストしてマクロを実行してみてください。
Sheet1のデータをSheet2に表示するようにしています。

Sub Sample1()
Dim i As Long, cnt As Long, wS As Worksheet
Set wS = Worksheets("Sheet1")
Worksheets("Sheet2").Cells.Clear
For i = 1 To wS.Cells(Rows.Count, "A").End(xlUp).Row
If wS.Cells(i, "A") = 1 Then
With wS.Cells(i, "A")
If .Offset(1, 0) = .Value And .Offset(0, 2) = .Value And .Offset(1, 2) = .Value And _
.Offset(0, 4) = 0 And .Offset(1, 4) = 0 Then
cnt = cnt + 1
.EntireRow.Copy Worksheets("Sheet2").Cells(cnt, "A")
End If
End With
End If
Next i
End Sub

こういうコトでしょうか？m(_ _)m

回答No.3

mindatg

>k＝1 to 1100でCells(k,1)＝Cells(k＋1,1)＝1,Cells(k,3)＝Cells(k＋1,3)＝1,Cells(k,6)＝Cells(k＋1,1)＝0となる行k行目を抜き出したいです。
>Cells(k,6)＝Cells(k＋1,1)＝0
だと破綻しているのでこちらで推測して訂正

正直なんのこっちゃサッパリわからん質問ですがアナタの心を読み解くワタシはエスパー
多分こんな感じでしょう↓

For k = 1 to 1000

If (Cells(k,1) = 1 AND Cells(k+1,1) = 1) AND _
(Cells(k,3) = 1 AND Cells(k+1,3) = 1) AND _
(Cells(k,6) = 0 AND Cells(k+1,6) = 0) THEN

' 条件に一致した行をコピー
Rows(k).Copy

' Sheet2に上から詰めて貼り付け
Worksheets("Sheet2").Rows(Worksheets("Sheet2").UsedRange.SpecialCells(xlLastCell).Row + 1).PasteSpecial

End If
Next k

' iとすべき箇所（多分列番号だと思いますが）は自分で手直ししてね

サンプルデータを仮に作成
1 あ 1 1
0 い 0 0
1 う 1 0
0 え 0 0
1 お 1 1
0 か 0 0
0 き 0 0
1 く 1 0
1 け 1 0
0 こ 0 0
1 さ 1 0
0 し 0 0
0 す 0 0
1 せ 1 0
1 そ 1 0
1 た 1 1
0 ち 0 0
1 つ 1 0
0 て 0 0
1 と 1 1
0 な 0 0
0 に 0 0
1 ぬ 1 0
1 ね 1 0
0 の 0 0
1 は 1 0
0 ひ 0 0
0 ふ 0 0
1 へ 1 0
1 ほ 1 0

条件に適合する行をコピーし貼り付け。添付画像イメージ

補足

ご回答感謝します。添付画像まで付けてくださり
大変参考になりました。
回答下さったうえで申し訳ないのですが、
もう１つ質問があります。

サンプルデータ
ABCD
----
1あ10
1い10
1う21
1え31
1お40
1か40
1き40
1く50
1け51
1こ51
1さ60
このサンプルデータで重複をはじきたいです。
・k列とk+1列を比べてA,C,Dの列が完全に一致する時、
　k列を抜き出して別のシートに張り付ける。
・k列とk+1列を比べてA,C,Dの列が一つでも異なる場合、
　k列とk+1列を抜き出して別のシートに張り付ける。

サンプルデータ重複を省くと以下のように
ABCD
----
1あ10
1う21
1え31
1お40
1く50
1け51
1さ60
このように抽出して別シートに張り付けたいです。
３つ以上の重複がある場合に教えていただいたやり方では
うまくいかないことがわかり再度質問させていただきました。

回答No.2

satoron666

そもそも、マクロの話ですか？
VBAの話ですか？
マクロとはマイクロソフトのエクセルに標準装備されている、
複数の手順を記憶して、自動的に実行させる機能のことを言います。
その場合なら、マクロの記録をやれば良いかと…

レイアウトは無くてもかまわないので、
やりたいことの流れを下記のように箇条書きにして下さい。
また、見やすいように改行を加えていただけるとありがたいです。

-----------------
(1)特定の行の抽出
抽出条件は何処に書き、どうするのですか。

A1セルに行番号を入力　　（例）　5
Sheet2のA列部分に抽出したものをコピーペースト

-----------------
(2)抽出した複数行を別シートに貼り付ける方法
複数行とはいっても、　５～７の場合もありますし、　1,5,8,9行などの場合もあるんですか？
よく分かりません。　補足してください。

-----------------
(3)
＞k＝1 to 1100で
Cells(k,1)＝Cells(k＋1,1)＝1,Cells(k,3)＝Cells(k＋1,3)＝1,
Cells(k,6)＝Cells(k＋1,1)＝0となる行k行目を抜き出したいです

ここまで分かっているのでしたら、自分で組めるのでは？
ここのプログラムの意味、やりたいことを箇条書きしてください。

例）A１と、B1が同じで、C１とD１が同じ場合に、
　　E１を抜き出したい！…というような書き方です。

-----------------

補足

遅くなってしまいすいません。
標準モジュールにマクロを書きます。
sheet1に記入されている1100行のデータから
Cells(k,1)＝Cells(k＋1,1)＝1,Cells(k,3)＝Cells(k＋1,3)＝1,
Cells(k,6)＝Cells(k＋1,1)＝0
となる行k行目を抜き出してsheet2に貼り付けたいです。
このプログラムの意味は、例として
A1＝A2,C1＝C2,E1＝E2の時に
1行目を取り出したいという意味です。
ただ数が多いため、何行になるか分からないので、
マクロを用いたいのです。
分かりにくくてすいません。

回答No.1

satoron666

(1)　特定の行を抽出する、キーワードはなんでしょうか。
　　　（1行目から7行目、　とかなのか、　「りんご」が含まれる行なのかなど）

(2)　(1)が分かってからの回答になると思います。

(3)　？？？
　　　シートのレイアウト例などを作成して頂けませんか？
　　　じゃないと、全然ピンときません。
> i=1,3,6でCells(k,i)=Cells(k+1,i)が成り立ち、Cells(k,i)の行だけを抜き出す
　　　k??? kとは何でしょうか。

とりあえうず、今の質問内容では回答することができません。
追記・補足をお願いします。

補足

質問不足で申し訳ありません。今すぐにはレイアウトを作ることができません。すいません(>_<)
k＝1 to 1100でCells(k,1)＝Cells(k＋1,1)＝1,Cells(k,3)＝Cells(k＋1,3)＝1,Cells(k,6)＝Cells(k＋1,1)＝0となる行k行目を抜き出したいです。
初心者なので説明も下手ですいません。
宜しくお願いします。