[[20140728153229]] 『AP列〜CU列の中で最右列の値を取得したい』(ぶどう) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『AP列〜CU列の中で最右列の値を取得したい』(ぶどう)

Sheet1のA列をキーとして、Sheet2のデータをコピペしたい。
その際に、Sheet2のAP列〜CU列はその中で最右列の値を取得したい。

AP〜CU列以外の値は下記で取得しました。
VBA初心者ですが、お知恵を貸して頂けると嬉しいです。

よろしくお願いします!

 Dim a As Range
        Dim b As Range
        Dim c As Range
        Dim D As Range
        Dim e As Range

        Dim myValue As Variant
        Dim myValue2 As Variant
        Dim myValue3 As Variant
        Dim myValue4 As Variant
        Dim myValue5 As Variant

        Dim i As Long
        Dim j As Long

        With Worksheets("Sheet1")  '書き込みするシート

            Set a = Worksheets("sheet2").Columns("E:L") '検索範囲
            Set b = Worksheets("sheet2").Columns("E:AB")
            Set c = Worksheets("sheet2").Columns("E:AC")
            Set D = Worksheets("sheet2").Columns("E:W")
            Set e = Worksheets("sheet2").Columns("E:O")

        Application.ScreenUpdating = False

                On Error Resume Next

                    For i = 2 To .Range("A1", .Range("A65536").End(xlUp)).Rows.Count
                        myValue = WorksheetFunction.VLookup(.Cells(i, 1).Value, a, 8, 0)
                        myValue2 = WorksheetFunction.VLookup(.Cells(i, 1).Value, b, 24, 0)
                        myValue3 = WorksheetFunction.VLookup(.Cells(i, 1).Value, c, 25, 0)
                        myValue4 = WorksheetFunction.VLookup(.Cells(i, 1).Value, D, 19, 0)
                        myValue5 = WorksheetFunction.VLookup(.Cells(i, 1).Value, e, 11, 0)

          'エラーが発生した時の値のクリア
          If Err > 0 Then
            Err.Clear: myValue = ""
            Err.Clear: myValue2 = ""
            Err.Clear: myValue3 = ""
            Err.Clear: myValue4 = ""
            Err.Clear: myValue5 = ""

          End If

            .Cells(i, 2).Value = myValue '値の書き込み
            .Cells(i, 3).Value = myValue2
            .Cells(i, 4).Value = myValue3
            .Cells(i, 5).Value = myValue4
            .Cells(i, 6).Value = myValue5

            Next i

            On Error GoTo 0
            Application.ScreenUpdating = True
                Set a = Nothing
                Set b = Nothing
                Set c = Nothing
                Set D = Nothing
                Set e = Nothing

        End With

< 使用 Excel:Excel2007、使用 OS:Windows7 >


 こんなことでしょうか。

 Sub Sample()
    Dim i As Long
    Dim c As Long
    Dim res As Range

    Application.ScreenUpdating = False
    With Worksheets("Sheet1")
        For i = 2 To .Range("A1", .Range("A65536").End(xlUp)).Rows.Count
            Set res = Worksheets("sheet2").Columns("E:E").Find(.Cells(i, "A").Value, lookat:=xlWhole)

            If res Is Nothing Then
                .Cells(i, "B").Resize(1, 5).ClearContents
            Else
                .Cells(i, "B").Value = Worksheets("Sheet2").Cells(res.Row, "L").Value
                .Cells(i, "C").Value = Worksheets("Sheet2").Cells(res.Row, "AB").Value
                .Cells(i, "D").Value = Worksheets("Sheet2").Cells(res.Row, "AC").Value
                .Cells(i, "E").Value = Worksheets("Sheet2").Cells(res.Row, "W").Value
                .Cells(i, "F").Value = Worksheets("Sheet2").Cells(res.Row, "O").Value

                '// CU から AP へデータを見ていって、見つかったらそこで書き出し。
                For c = Range("CU1").Column To Range("AP1").Column Step -1
                    If Worksheets("Sheet2").Cells(res.Row, c).Value <> "" Then
                        .Cells(i, c).Value = Worksheets("Sheet2").Cells(res.Row, c).Value '// 書き出しを同一にしたかったら、Cells(i,c) の c を変更
                        Exit For   '// 見つかったら処理を終了
                    End If
                Next

            End If
        Next
    End With
    Application.ScreenUpdating = True
 End Sub

(Mook) 2014/07/28(月) 16:28


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.