[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『マクロで一致するデータの切り取り、貼り付け処理』（左利き）
今日からマクロを勉強するド素人です。宜しくお願いします。
シート1に元データとなる情報が入力されています。
sheet1
A B C D
1 ｺｰﾄﾞ 日付 商品 ｶﾗｰ
2 2 1/1 机 黒
3 2 1/2 椅子 白
4 2 1/2 椅子 白
5 3 1/2 椅子 黄
シート2に"検索条件"となるデータを以下の通り固定のセルに入力した際、
sheet2
A B C D
1 ｺｰﾄﾞ 日付 商品 ｶﾗｰ
2 2 1/2 椅子 白
完全に一致するシート1の(A3:D3)のデータを切り取り、シート2の(A10:D10)に貼り付けたいのです。
この表のように重複するデータがいくつか存在する場合は、最上部にあるデータを1つだけ切り取り、貼り付けを実行したいのです。次に別の"検索条件"入力した場合も、やはり合致するデータをシート2の(A10)に貼り付け、それまでのデータは順次一段下にずれていく･･･、という具合にしたいのです。
何卒、お力添えを宜しくお願い致します。
とりあえず、作ってみました。
アドバンスフィルターで抽出し、貼り付けています。
マクロの記録からいじったので、改善の余地がありそうです。
(SHIOJII）
Sub test()
Dim myR As Range
Application.ScreenUpdating = False
With Sheets("Sheet1")
Set myR = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Resize(, 4)
myR.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("Sheet2").Range("A1:D2"), Unique:=True
If myR.SpecialCells(xlCellTypeVisible).Columns(1).Rows.Count <> 1 Then
With Sheets("Sheet2")
If Range("A11").Value <> "" Then
.Rows(11).Insert (xlShiftDown)
End If
End With
myR.SpecialCells(xlCellTypeVisible).Copy
Sheets("Sheet2").Range("A10").PasteSpecial
Application.CutCopyMode = False
Else
MsgBox "一致するデータはありません。"
End If
.ShowAllData
End With
Application.ScreenUpdating = False
End Sub
(SHIOJII)さんありがとうございました。
早速試してみたのですが、"一致するデータはありません。"となってしまいます。
私の下手な説明でご迷惑をお掛けしますが、再度検討願えないでしょうか。
判らないなりにも以下の部分を自分なりに修正してみました。
Set myR = .Range("A1", → Set myR = .Range("A2",
Sheets("Sheet2").Range("A1:D2"), →Sheets("Sheet2").Range("A2:D2"),
このように変更すると一致しないものまで貼り付けられ、かつ、sheet1には情報が残ったままです。
お忙しいところ申し訳ありませんが、よろしくお願い致します。 (左利き)
横から失礼します。 >If myR.SpecialCells(xlCellTypeVisible).Columns(1).Rows.Count <> 1 Then ⇒If myR.SpecialCells(xlCellTypeVisible).Columns(1).Rows.Count = 1 Then では、ないでしょうか？ (じゅんじゅん)
転記まではできましたが・・・
>完全に一致するシート1の(A3:D3)のデータを切り取り
を完全に読み落としていました。 ~~~~~~~~~
時間がないので夜考えてみます。
その間に識者の方が答えてくれると思います。
Dictionaryを使って転記した方がいいかもしれない？？
(SHIOJII）
Sub test()
Dim myR As Range
Dim myCnt As Integer
Application.ScreenUpdating = False
With Sheets("Sheet1")
Set myR = .Range("A1", .Cells(Rows.Count, 1).End(xlUp)).Resize(, 4)
myR.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
Sheets("Sheet2").Range("A1:D2"), Unique:=True
myCnt = myR.Columns(1).SpecialCells(xlCellTypeVisible).Count
If myCnt <> 1 Then
With Sheets("Sheet2")
If Range("A11").Value <> "" Then
.Rows(11).Insert (xlShiftDown)
End If
End With
myR.SpecialCells(xlCellTypeVisible).Copy
Sheets("Sheet2").Range("A10").PasteSpecial
Application.CutCopyMode = False
Else
MsgBox "一致するデータはありません。"
End If
.ShowAllData
End With
Application.ScreenUpdating = False
End Sub
じゅんじゅんさん、SHIOJIIさんありがとうございます。 お手間を取らせますが、宜しくお願い致します。 (左利き)
時間が合ったので
普通に見ていきました。
(SHIOJII）
Sub test2()
Dim myCnt As Long
Dim myVal As Variant
Dim r As Range
With Sheets("Sheet2")
myVal = .Range("A2").Value & .Range("B2").Value & .Range("C2").Value & .Range("D2").Value
If .Range("A10").Value = "" Then
.Range("A10").Resize(, 4).Value = .Range("A1").Resize(, 4).Value
End If
End With
With Sheets("Sheet1")
For Each r In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
myval2 = r.Value & r.Offset(, 1).Value & r.Offset(, 2).Value & r.Offset(, 3).Value
If myval2 = myVal Then
r.Offset(, 26).Value = 1
myCnt = myCnt + 1
End If
Next
On Error Resume Next
.Range("AA:AA").SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
On Error GoTo 0
End With
If myCnt > 0 Then
With Sheets("sheet2")
If .Range("A11") <> "" Then
.Rows(11).Insert (xlShiftDown)
End If
.Range("A11").Resize(, 4).Value = .Range("A2").Resize(, 4).Value
End With
Else
MsgBox "一致するデータはありません。"
End If
End Sub
出来ましたーっ！！ これまでにかなり悩んできただけあって、出来栄えに感動です。 SHIOJIIさん本当に有難うございました。 (左利き)
とりあえず解決してよかったですが、
>今日からマクロを勉強するド素人です。宜しくお願いします。
ということなので、もう見てないかもしれないけど、参考になればと思い、注釈をつけてみました。
検索の仕方や行削除の仕方などほかにもいろいろと方法があると思いますが・・・
(SHIOJII）
Sub test2()
'変数宣言
Dim myCnt As Long '一致行判断のため
Dim myVal As Variant '検索値格納のため
Dim myVal2 As Variant '被検索値格納のため
Dim r As Range
'シート2において
With Sheets("Sheet2")
'myValにA2からD2までの値を連結して代入
myVal = .Range("A2").Value & .Range("B2").Value & .Range("C2").Value & .Range("D2").Value
'A10に見出し行がなかったら、
If .Range("A10").Value = "" Then
'A1からD1までの見出し行の挿入（一番はじめだけ必要）
.Range("A10").Resize(, 4).Value = .Range("A1").Resize(, 4).Value
End If
'以上がシート2においてすること
End With
'シート1において
With Sheets("Sheet1")
'A列を上から一つずつ順番に見ていき
For Each r In .Range(.Cells(1, 1), .Cells(Rows.Count, 1).End(xlUp))
'myval2にA列からD列の値を連結して格納
myVal2 = r.Value & r.Offset(, 1).Value & r.Offset(, 2).Value & r.Offset(, 3).Value
'もしmyVal2とmyValが一致したら
If myVal2 = myVal Then
'一致した行のAA列に「1」を入力（後で行削除するため）
r.Offset(, 26).Value = 1
'myCntに一致した数を代入（一致したものがあるか判定するため）
myCnt = myCnt + 1
End If
'次の行へ
Next
'エラーがあっても次の処理をするためのエラートラップ
On Error Resume Next
'AA列に数字の1があれば、その行を削除。SpecialCellsはそのセルがないとエラーになります。
.Range("AA:AA").SpecialCells(xlCellTypeConstants, 1).EntireRow.Delete
'エラートラップを解除
On Error GoTo 0
'以上がシート1においてすること
End With
'もしmyCntが0でない、つまり一致する行があったら、
If myCnt > 0 Then
'シート2において
With Sheets("sheet2")
'A11に何か値があったら､つまり2回目以降の転記の時
If .Range("A11") <> "" Then
'行挿入をしなさい
.Rows(11).Insert (xlShiftDown)
End If
'検索値と記入値が同じなので、検索値（A2からD2）をA11を記入
.Range("A11").Resize(, 4).Value = .Range("A2").Resize(, 4).Value
'以上がシート2においてすること
End With
'それ以外、つまりmyCnt=0、一致する行が見つからなければ
Else
'次のメッセージを出しなさい
MsgBox "一致するデータはありません。"
End If
End Sub
･･･ホントはこの注釈が欲しかったんです。 これらのコードは何をどのように命令しているか解らず、本やネットで調べていたんですが、途中で挫折し･･･。 もっとホントの事を言うと、私の操作したいファイルに置き換えたときには動かなかったんです･･･。 おかげ様で現在は、使用したいファイルが私のイメージしていた通りに動いております。 SHIOJII様には心より感謝しております。 (左利き)
>おかげ様で現在は、使用したいファイルが私のイメージしていた通りに動いておりま す。
それは、なによりです。
>これらのコードは何をどのように命令しているか解らず、本やネットで調べていたんですが、途中で挫折し･･･。 >もっとホントの事を言うと、私の操作したいファイルに置き換えたときには動かなかったんです･･･。
私もマクロを始めた頃は、変数なのか関数なのかチンプンカンプンでヘルプと本、後は こんな掲示板で初歩的な質問をたくさんしていました。
私にとってVBAは楽しみの一つで、掲示板は学習の場だと考えています。 自分にできそうなものがあったりすると、ヘルプやネットで調べて答えられるようにがんばっています。 下手なコードでも、誰かのお役に立てば、今まで教えてくれた人たちへのお礼になります。
これからも一緒に勉強していきましょう。
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.