エクセル2010 検索とデータ移動

質問

エクセル2010を使っています。

【Sheet2】に画像の様な表があり、その表を【Sheet４】に移動したいのですが、条件があります。

表は　【Sheet２】の　T列～DE列に必ず存在（全て同じサイズ）

行数は必ず８行。

その表のうち、T列の最上部に　１　が入力されているものだけを　【Sheet　４】　のA１　に上から順に表示させたいのです。

詳しい方、教えていただけませんか？

よろしくお願い致します。

回答No.7

eden3616 · ベストアンサー

No6の修正箇所ですが、他にも問題点がありました。
表の間隔が２つ目以降適応されない・・・・

最終的に以下のようにしてください。

myRow = cnt * 8 + sp
　　　↓
myRow = cnt * 8 + cnt * sp + Range(myRng).Row

No4のコードからNo5へ修正する際に、
次の表の表示先の行番号の差分を現在の行番号に毎回加算していたのですが
cntで表の数をカウントしたかったために等差数式で求める形式に変更したことが要因でした。
cntは他の処理部分で使用していませんので、処理自身に影響はないかと思います。

度重なり失礼いたしました。

お礼

早速の回答ありがとうございます。

その上しっかりと検証までして頂き、感謝感謝を感じております、ありがとうございます。

今回のコードでは理想の結果が得られ良かったです。

スピードも速くなって、大変便利だと思います。

また、毎日100行ほどの追記があり、マクロで出来る事で重宝しています。

最後まで、ご指導下さりありがとうございました！

回答No.6

eden3616

>Ctrl+Fでの検索の件ですが、１のあるセルの下に2,3,4,5,6,7,8と連番がある場所があるのですが、
>全て１で検索されてしまい、私も？？？ｔって感じになっています。

なぜでしょうね？データを拝見できないので何とも言えませんが。

>それで、1点、疑問に思う場所があるのですが、最初に抜き出した一つ目の表、
>これのみが7行で終えてしまい、8行目が表示されずに次の表を表示してしまいます。
>次の表（二つ目）からは正常に表示されているようです。

No5のコード修正で確認をせず変更した付けがきましたね。。。
申し訳ありませんでした。

コード中盤より下側（'表のコピー処理の後半部分）にある以下の箇所を変更してください。
開始行数分をずらすのを忘れておりました。

myRow = cnt * 8 + sp
　　　　　↓
myRow = cnt * 8 + sp + Range(myRng).Row

>※　ちなみに抜き出した表の数　875件　秒数　30秒程度でした。

速度向上出来ているようで良かったです。
処理内容的に大したことしてないんですが、セルのコピー貼付となると15万行の精査には時間がかかりますね・・・。
既読性・後修正の容易さによる記述及び、設定による判定など本来不要な処理も入れているため、
最速で処理されるコードからみれば雑多なコードで申し訳ありませんが。
関数やフィルタ使った方が早かったかも・・・？

回答No.5

eden3616

>まず、最初に、Ctrl+Fでは検索してくれませんでした。

Ctrl+Fからの検索でヒットすれば、その条件でFind検索（No1のコード）でもいけそうですね。

>それで、最後に頂いた、コードを試してみたところ、これが良い感じで動くではありませんか！
>嬉しくって待つこと１５分、（元データが15万行程度にわたるため）、
>どうやら正常に抜き出してくれたようです。
>表の中身は他セルへのリンク等も含まれるのですね、
>ですからその部分が見事に＃REF!になってしまいました><
>何度も訂正して頂き、ありがたいのですが、この最後の貼り付けを
>【値】で貼り付けることは可能でしょうか？
>追記です、値のみでなく表の枠線も貼り付けたいです、

15万ですか。こちらの想定行数より多いですね。
時間がかかりそうなので、速度向上と経過を表示するように修正しました。

具体的には以下の変更を行いました。

・全体的な処理速度の向上
・設定の初期値を変更（列幅のコピー）
・書式及び値をコピーする処理へ変更
・ENDキーで処理を中断できるように変更（"いいえ"を選択て続きから再開）
・進行度合いを左下に表示するように変更
・終了時にコピー結果を表示するように変更

下記コードを全て入れ替えて再度実行してください。

■VBAコード
Declare Function GetAsyncKeyState Lib "User32.dll" (ByVal vKey As Long) As Long
Sub sample()
Dim tar As Range, bk As Range, dlRng As Range, key As Variant
Dim mySt(1) As Worksheet, flag(1) As Integer, myRng As String
Dim cnt As Long, sp As Integer, myCol As String
Dim myRow As Long, maxRow As Long, tarRow As Long, myCopy As Range

'▼ここから設定▼
'検索する値（文字を指定する場合は""で括ること：key = "abc"）
key = 1
'対象の表があるシート
Set mySt(0) = Worksheets("Sheet2")
'コピー先のシート
Set mySt(1) = Worksheets("Sheet4")
'コピー先の開始セル（このセルを基点として下方向にコピー）
myRng = "A1"
'表のセル間隔（表を詰める=無しの場合は0）
sp = 0
'列の幅をコピーするかどうか（する場合は1、しない場合は0）
flag(0) = 1
'コピー後に元データを削除するかどうか（する場合は1、しない場合は0）
flag(1) = 0
'▲設定ここまで▲

With mySt(0)
　　'準備
　　Application.StatusBar = "実行中：しばらくお待ちください。"
　　Set tar = srch(key, mySt(0), "T", tar)
　　If tar Is Nothing Then
　　　　MsgBox """" & key & """が見つかりませんでした。"
　　　　Exit Sub
　　End If
　　maxRow = .Cells(Rows.Count, "T").End(xlUp).Row
　　myRow = Range(myRng).Row
　　mySt(1).Cells.Delete
　　'列幅複写
　　If flag(0) Then
　　　　Application.StatusBar = "列幅を設定しています..."
　　　　.Range(.Columns("T"), .Columns("DE")).Copy
　　　　mySt(1).Columns(Range(myRng).Column).PasteSpecial Paste:=xlPasteColumnWidths
　　End If
　　'表のコピー処理
　　Set bk = tar
　　Application.ScreenUpdating = False
　　Do
　　　　If GetAsyncKeyState(35) <> 0 Then
　　　　　　GoSub exit_ans
　　　　End If
　　　　tarRow = tar.Row + 7
　　　　If flag(1) Then
　　　　　　If dlRng Is Nothing Then
　　　　　　　　Set dlRng = .Range(tar, .Cells(tarRow, "DE"))
　　　　　　Else
　　　　　　　　Set dlRng = Union(dlRng, .Range(tar, .Cells(tarRow, "DE")))
　　　　　　End If
　　　　End If
　　　　.Range(tar, .Cells(tarRow, "DE")).Copy
　　　　With mySt(1).Cells(myRow, Range(myRng).Column)
　　　　　　.PasteSpecial Paste:=xlPasteFormats
　　　　　　.PasteSpecial Paste:=xlPasteValues
　　　　End With
　　　　Set tar = srch(key, mySt(0), "T", tar)
　　　　cnt = cnt + 1
　　　　myRow = cnt * 8 + sp
　　　　If cnt Mod (Int(maxRow / 1000) + 1) = 0 Then
　　　　　　Application.StatusBar = "複写処理中：現在[" & Int(tarRow * 100 / maxRow) & "%] " & tarRow & "行を処理しています"
　　　　　　DoEvents
　　　　End If
　　Loop Until tar Is Nothing
　　'終了処理
　　Application.ScreenUpdating = True
　　Application.StatusBar = "終了確認"
　　MsgBox "完了しました" & vbCrLf & "コピーした表の数：" & cnt & "件"
　　Application.EnableCancelKey = xlInterrupt
　　Application.StatusBar = False
End With
If flag(1) Then dlRng.Delete
Exit Sub
'ENDキー入力時の終了確認
exit_ans:
　　Application.StatusBar = "ENDが押されました"
　　If MsgBox("マクロを強制終了しますか？", vbYesNo, "確認") = vbYes Then
　　　　MsgBox "中断しました" & vbCrLf & "コピーした表の数：" & cnt & "件"
　　　　Application.EnableCancelKey = xlInterrupt
　　　　Application.StatusBar = False
　　　　Exit Sub
　　End If
　　Return
End Sub
Function srch(key As Variant, mySt As Worksheet, _
　　myCol As String, tar As Range) As Range
　　Dim i As Long, j As Long, cnt As Long
　　On Error GoTo era:
　　With mySt
　　　　If tar Is Nothing Then Set tar = .Cells(1, myCol) _
　　　　　　Else Set tar = tar.Offset(1, 0)
　　　　Set sRng = .Range(tar, .Cells(Rows.Count, myCol))
　　　　cnt = WorksheetFunction.Match(key, sRng, 0) - 1
　　　　Set srch = tar.Offset(cnt, 0)
　　End With
　　Exit Function
era:
　　Set srch = Nothing
End Function

補足

再々度の回答ありがとうございます。

Ctrl+Fでの検索の件ですが、１のあるセルの下に2,3,4,5,6,7,8と連番がある場所があるのですが、全て１で検索されてしまい、私も？？？ｔって感じになっています。

そして本題のコードの件ですが、高速なコードまで書いて頂き、大変感謝いたします、ありがとうございます。

それで、1点、疑問に思う場所があるのですが、最初に抜き出した一つ目の表、これのみが7行で終えてしまい、8行目が表示されずに次の表を表示してしまいます。

次の表（二つ目）からは正常に表示されているようです。

重ね重ねお手数とは思いますが、教えて頂けないでしょうか。

よろしくお願い致します。

※　ちなみに抜き出した表の数　875件　秒数　30秒程度でした。

回答No.4

eden3616

こちらで再現されないので何とも言えませんが・・・・。
色々やり方を変えてみます。

>シート名を確認し、修正コードを反映させてみたのですがやはり
>１が見つからないとのレスポンスですね。
>ちなみに、頂いたコードの設定はそのまま利用しています。
>最後に念のため　ダブルクォーテーションも試してみたのですが、同じ結果です。

T列を選択して手動検索（Ctrl+F）で「1」が見つかりますか？
見つかる場合、No2のコードを元に戻した状態にして実行し直してみてください。

>T列の同じ表内には連番で１～８の文字なので、重複は無いのですが、
>こういう場合、T４にある１が見た目１に見えて１じゃないって事が濃厚ですよね？

小数での計算であれば、
=0.999999999999+0.00000000001
などは1にならず、「 1.000000000009」と取得してしまい
（エクセルの小数点以下の計算誤差による影響）
マッチングしない場合もありますが、Find検索では上記例でも一致しました。

>ただ、１じゃない場合は、ダブルクォーテーションでカバーできると言う事ですよね。

一度、T列の該当セルへセル書式標準で「1」半角数字を入力したうえで、
key=1としてマッチングするか確認して頂けますでしょうか？

>表のT列にある数字はさまざまな物が入って居て、ハイフンがあったり、＃VALUEが有ったりするのですが。

数式エラーやハイフンの存在は今回の件とは無関係のようです。

以下はシート関数のMatchによる検索に置き換えたものです。
現在のコードと全て置き換えて実行してください。

Sub sample()
Dim tar As Range, bk As Range, dlRng As Range, key As Variant
Dim mySt(1) As Worksheet, flag(1) As Integer
Dim cnt As Long, sp As Integer, myCol As String

'▼ここから設定▼
'検索する値（文字を指定する場合は""で括ること：key = "abc"）
key = 1
'対象の表があるシート
Set mySt(0) = Worksheets("Sheet2")
'コピー先のシート
Set mySt(1) = Worksheets("Sheet4")
'コピー先の開始セル（このセルを基点として下方向にコピー）
myRng = "A1"
'表のセル間隔（表を詰める=無しの場合は0）
sp = 0
'列の幅をコピーするかどうか（する場合は1、しない場合は0）
flag(0) = 0
'コピー後に元データを削除するかどうか（する場合は1、しない場合は0）
flag(1) = 0
'▲設定ここまで▲

With mySt(0)
　　'準備
　　Set tar = srch(key, mySt(0), "T", tar)
　　If tar Is Nothing Then
　　　　MsgBox """" & key & """が見つかりませんでした。"
　　　　Exit Sub
　　End If
　　cnt = Range(myRng).Row
　　mySt(1).Cells.Delete
　　'列幅複写
　　If flag(0) Then
　　　　.Range(.Columns("T"), .Columns("DE")).Copy mySt(1).Columns(Range(myRng).Column)
　　　　mySt(1).Range(mySt(1).Rows(1), mySt(1).Rows(Rows.Count - 1)).Delete shift:=xlUp
　　End If
　　'表のコピー処理
　　Set bk = tar
　　Do
　　　　If dlRng Is Nothing Then
　　　　　　Set dlRng = .Range(tar, .Cells(tar.Row + 7, "DE"))
　　　　Else
　　　　　　Set dlRng = Union(dlRng, .Range(tar, .Cells(tar.Row + 7, "DE")))
　　　　End If
　　　　.Range(tar, .Cells(tar.Row + 7, "DE")).Copy mySt(1).Cells(cnt, Range(myRng).Column)
　　　　Set tar = srch(key, mySt(0), "T", tar)
　　　　cnt = cnt + 8 + sp
　　Loop Until tar Is Nothing
End With
If flag(1) Then dlRng.Delete
End Sub
Function srch(key As Variant, mySt As Worksheet, _
　　myCol As String, tar As Range) As Range
　　Dim i As Long, j As Long, cnt As Long
　　On Error GoTo era:
　　With mySt
　　　　If tar Is Nothing Then Set tar = .Cells(1, myCol) _
　　　　　　Else Set tar = tar.Offset(1, 0)
　　　　Set sRng = .Range(tar, .Cells(Rows.Count, myCol))
　　　　cnt = WorksheetFunction.Match(key, sRng, 0) - 1
　　　　Set srch = tar.Offset(cnt, 0)
　　End With
　　Exit Function
era:
　　Set srch = Nothing
End Function

お礼

追記です、値のみでなく表の枠線も貼り付けたいです、度々ですが、どうぞよろしくお願い致します。

補足

再々の対応いただきまして、本当にありがとうございます。

まず、最初に、Ctrl+Fでは検索してくれませんでした。

それで、最後に頂いた、コードを試してみたところ、これが良い感じで動くではありませんか！

嬉しくって待つこと１５分、（元データが15万行程度にわたるため）、どうやら正常に抜き出してくれたようです。

チェックのため、下行にスクロールしていると・・・・一つ問題が。

表の中身は他セルへのリンク等も含まれるのですね、ですからその部分が見事に＃REF!になってしまいました><

何度も訂正して頂き、ありがたいのですが、この最後の貼り付けを【値】で貼り付けることは可能でしょうか？

よろしくお願い致します。

回答No.3

eden3616

度々失礼します。
申し訳ありませんでした。
おそらくこれが原因かと思いますので修正願います。
（コード中ほどにあります）

Set tar = .Columns("T").Find(key)
　　　　↓
Set tar = .Columns("T").Find(key, , xlValues, xlWhole, xlByRows, xlNext, True, True, False)

※補足※
このコードで使用しているFind検索は
検索オプションを使用しなかった場合、ユーザーが前回使用した検索オプションを継承します。
このため、こちらのテスト環境と異なる検索結果になった思われます。

この修正により以下の設定でオプション指定して実行するように変更しました。

　　検索する文字列：keyで指定した値
　　検索場所：mySt(0)で指定したシートのT列
　　検索方向：行
　　検索対象：値
　　大文字と小文字の区別：する
　　セル内容の完全一致：する
　　半角全角の区別：する
　　書式検索：しない

補足

再度の回答ありがとうございます。

シート名を確認し、修正コードを反映させてみたのですがやはり　１が見つからないとのレスポンスですね。

ちなみに、頂いたコードの設定はそのまま利用しています。

最後に念のため　ダブルクォーテーションも試してみたのですが、同じ結果です。

T列の同じ表内には連番で１～８の文字なので、重複は無いのですが、こういう場合、T４にある１が見た目
１に見えて１じゃないって事が濃厚ですよね？

ただ、１じゃない場合は、ダブルクォーテーションでカバーできると言う事ですよね。

あ・・・もしかして、これでしょうか？

表のT列にある数字はさまざまな物が入って居て、ハイフンがあったり、＃VALUEが有ったりするのですが。

回答No.2

eden3616

>やってみました、VBAは正常に動いてるようですが、１が見つかりませんと出てしまいます。
>試しに、Tセルに×１して試してみたり、Tセルの書式設定を【数値】に変更しなおしてみたり、
>セルの１をコピーして、key = 1　の部分に貼り付けてみたりしたのですが、
>１が見つからないメッセージボックスが出てしまいます。

Set mySt(0) = Worksheets("Sheet2")

上記設定は間違えていませんか？
存在しないシート名を指定した場合はエラーになりますが、動作しているとのことですので
存在している対象外のシート名を指定していませんか？
初期設定のままですと、「Sheet2」の「T列」にある「1」を検索します。

また、「半角数字以外」をkeyとする場合は、
「key="１"」とダブルクォーテーションで括って指定してください。

今回の件と関係はないんですが、No1の捕捉となります。
No1のコードにおいて以下の前提条件があります。

・keyとなる値は同じ表のT列に2個以上存在しない事

もしそのような場合であればコードを修正する必要がありますので、補足願います。

回答No.1

eden3616

「表の移動」とは「コピー」なのか「切取貼付」なのか、
それとも「コピー後削除(シフトアップ等)」なのかで処理内容が異なります。
以下はVBAによる方法です。
（関数とフィルタでコピーできそうですが・・・）

(1)Alt+F11でVBEを開き、挿入→標準モジュールを選択
(2)作成された標準モジュールへ下記のVBAコードを貼付
(3)コード内の「▼ここから設定▼」～「▲設定ここまで▲」を修正
(4)Alt+F11でVBEを閉じて、Alt+F8から「sample」マクロを選び実行

※補足
(3)の設定において、以下の値を0で「コピー」、1で「切取貼付」となります。
　　　　flag(1) = 0

■VBAコード

Sub sample()
Dim tar As Range, bk As Range, dlRng As Range, key As Variant
Dim mySt(1) As Worksheet, flag(1) As Integer
Dim cnt As Long, sp As Integer, myCol As String

'▼ここから設定▼
'検索する値（文字を指定する場合は""で括ること：key = "abc"）
key = 1
'対象の表があるシート
Set mySt(0) = Worksheets("Sheet2")
'コピー先のシート
Set mySt(1) = Worksheets("Sheet4")
'コピー先の開始セル（このセルを基点として下方向にコピー）
myRng = "A1"
'表のセル間隔（表を詰める=無しの場合は0）
sp = 0
'列の幅をコピーするかどうか（する場合は1、しない場合は0）
flag(0) = 1
'コピー後に元データを削除するかどうか（する場合は1、しない場合は0）
flag(1) = 0
'▲設定ここまで▲

With mySt(0)
　　'準備
　　Set tar = .Columns("T").Find(key)
　　If tar Is Nothing Then
　　　　MsgBox """" & key & """が見つかりませんでした。"
　　　　Exit Sub
　　End If
　　cnt = Range(myRng).Row
　　mySt(1).Cells.Delete
　　'列幅複写
　　If flag(0) Then
　　　　.Range(.Columns("T"), .Columns("DE")).Copy mySt(1).Columns(Range(myRng).Column)
　　　　mySt(1).Range(mySt(1).Rows(1), mySt(1).Rows(Rows.Count - 1)).Delete shift:=xlUp
　　End If
　　'表のコピー処理
　　Set bk = tar
　　Do
　　　　If dlRng Is Nothing Then
　　　　　　Set dlRng = .Range(tar, .Cells(tar.Row + 7, "DE"))
　　　　Else
　　　　　　Set dlRng = Union(dlRng, .Range(tar, .Cells(tar.Row + 7, "DE")))
　　　　End If
　　　　.Range(tar, .Cells(tar.Row + 7, "DE")).Copy mySt(1).Cells(cnt, Range(myRng).Column)
　　　　Set tar = .Columns("T").FindNext(tar)
　　　　cnt = cnt + 8 + sp
　　Loop Until bk.Address = tar.Address
End With
If flag(1) Then dlRng.Delete
End Sub

補足

回答ありがとうございます。

やってみました、VBAは正常に動いてるようですが、１が見つかりませんと出てしまいます。

試しに、Tセルに×１して試してみたり、Tセルの書式設定を【数値】に変更しなおしてみたり、セルの１をコピーして、key = 1　の部分に貼り付けてみたりしたのですが、１が見つからないメッセージボックスが出てしまいます。

何処かに、お心当たりがありますでしょうか？

よろしくお願い致します。