[[20221126160533]]　『行と列が一致したら転記したい。』（苦戦）　ページの最後に飛ぶ

『行と列が一致したら転記したい。』（苦戦）

初めまして。教えて下さい。
下記のように、元シートと先シートがあります。

＜元シート＞

    A	 B	C	D	E	F
 1  A	 B	C	D	E	F
 2  No.	 月	種類	色	判定	数
 3  1	 1月	A	赤	OK	3
 4  3	 2月	A	黄	NG	5
 5  2	 2月	C	黄	OK	2
 6  4	 3月	B	赤	OK	3

＜先シート＞

    A	 B	C	D
 1  A	 C	B	F
 2  No.	 種類	月	数

元シートに表があり、1行目には列番号が予めふられている。
先シートの1行目には、元シートから転記してきたい元シートの列番号がふってある。（2行目にも予め該当列の項目名記載済）
1行目同士をmatchさせて、合致したら表を転記する所までは出来ました。
（A列のNo.にはリンクがついている為、そのまま保持して転記したい。）

Sub 転記()
Dim 先 As Long
Dim 列 As Variant
Dim LastRow As Long

LastRow = Worksheets("元").Range("A" & Rows.Count).End(xlUp).Row

With Worksheets("先")

    For 先 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
        If .Cells(1, 先).Value <> "" Then
            列 = Application.Match(.Cells(1, 先).Value, Worksheets("元").Rows(1), 0)
            If Not IsError(列) Then
                Intersect(Worksheets("元").Rows("3:" & LastRow), Worksheets("元").Columns(列)).Copy Destination:=.Cells(3, 先)
            End If
        End If
    Next 先
End With
End Sub

今回更にやりたい事は、元シートのE列：判定が　”OK”　の行のみ転記したいです。
1行目の列番号が一致し、更にE列判定がOKのものを転記するという作業を
一気に実施するにはどのようにやれば良いかが分かりません。
一応自分なりに、下記コードを考えたのですが、うまく行かない部分が2箇所あります。
　その1 → 行、列をそれぞれループで見ていくやり方なので時間がかかる。(実際のデータは2,000行ほど有り）
　その2 → 考えたやり方だと、貼り付け先に空白行が出来てしまう。
　　　　　空白が出来る理由(変数「行」がOKでない場合このコードでは空白が出来てしまう）は分かったものの
　　　　　ではどうすればよいか、が分かりません。。
VBAの勉強を始めたばかりで、試行錯誤の連続です。
1, 2の双方が解決するような良い方法ありましたら、ご教授頂けますと嬉しいです。
今検討中のコードです↓↓

Sub 転記2()
Dim 先 As Long
Dim 列 As Variant
Dim LastRow As Long

LastRow = Worksheets("元").Range("A" & Rows.Count).End(xlUp).Row

With Worksheets("先")

 For 行 = 3 To LastRow
    For 先 = 1 To .Cells(1, .Columns.Count).End(xlToLeft).Column
     If Worksheets("元").Cells(行, 5).Value = "OK" Then
        If .Cells(1, 先).Value <> "" Then
            列 = Application.Match(.Cells(1, 先).Value, Worksheets("元").Rows(1), 0)
            If Not IsError(列) Then
                Intersect(Worksheets("元").Rows(行), Worksheets("元").Columns(列)).Copy Destination:=.Cells(行, 先)
            End If
        End If
     End If
    Next 先
 Next 行
End With
End Sub

＜使用 Excel：Office365、使用 OS：Windows10 ＞

こんばんわ。。。＾＾
様々な方法が有ると思います。一案で
リンクが無ければ、配列を使えば幾分
スピードアップ出来るかもしれませんがリンクは消し飛ぶと
思いますので。そのぉ

フイルター詳細で抽出してから
要らない列を削除する、とかでは。。。＾＾；
でわでわ
m(__)m

（隠居Z） 2022/11/26(土) 18:04:39

 Sub test()
     Dim ws1 As Worksheet, ws2 As Worksheet
     Set ws1 = Worksheets("元")
     Set ws2 = Worksheets("先")
     With ws1
         .Rows(2).AutoFilter 5, "OK"
         .Range("A1").CurrentRegion.Copy ws2.Range("A1")
         .Range("A1").AutoFilter
     End With
     With ws2
         .Columns("D:E").Delete
         .Columns("C").Cut
         .Columns("B").Insert Shift:=xlToRight
     End With
 End Sub
（フォーキー） 2022/11/26(土) 18:17:49

早速ありがとうございます！
やはり、オートフィルター等で抽出してから列削除の方法が速く出来そうなのですね。
ただ、列も実際は50行位あってその順序も変えたりするので、悩ましい所です^^;
皆さんから教えて頂いた事を取り入れながら、いま一度考えてみたいと思います。

配列はリンクが切れるのですね。情報ありがとうございます！
（苦戦） 2022/11/26(土) 20:17:18

＞＞配列はリンクが切れるのですね。
一概にそぉとは言い切れません、やり方次第とでもいいましょうか。
コピペなら出来なくはないと思います。
色々、お試しになると、楽しいですよ。でわ。m(__)m
（隠居Z） 2022/11/26(土) 20:38:45

コメント返信：

[ 一覧(最新更新順) ]

[[20221126160533]] 『行と列が一致したら転記したい。』（苦戦） ページの最後に飛ぶ

[[20221126160533]]　『行と列が一致したら転記したい。』（苦戦）　ページの最後に飛ぶ