1

vlookup 用のマクロを作成したいのですが、私の場合、列の参照が 1 つの基準から次の基準に自動的に変更されます。問題は次のとおりです。

1 つの Excel シートに、すべての企業と利用可能な製品のリストがあります。

http://wikisend.com/download/910578/product.jpg

これで、各企業のシートができました。各会社のvlookupを行い、利用可能な製品を特定の会社シートに入れたいです。新しいシートはこのようになります。

http://wikisend.com/download/482612/single comp.png

各会社の列には既に製品名があるため、列をコピーして挿入することはできません。また、すべての会社に対してマクロを実行したい (各会社は X1 として別のシートを持っています)。

ご協力ありがとうございました。

更新されたコード:

Sub UpProd()
    Dim ws As Worksheet
    Dim DataRange As Range, UpdateRange As Range, aCell As Range, bCell As Range
    Dim s As String
    Dim z As Variant
    s = "X1,X2,X3"
    z = VBA.Split(s, ",")
    On Error GoTo Err

    For Each i In z
        Set ws = Worksheets("Sheet5")
        Set UpdateRange = Worksheets(i).Range("A2:A21")
        Set DataRange = ws.Range("A2:A12")
        For Each aCell In UpdateRange
            Set bCell = DataRange.Find(What:=aCell, LookIn:=xlValues, _
                        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                        MatchCase:=False, SearchFormat:=False)

           If Not aCell Is Nothing Then
                aCell.Offset(, 1) = bCell.Offset(, 1)
            End If
        Next
    Next i
    Exit Sub
Err:
    MsgBox Err.Description
End Sub
4

1 に答える 1

1

問題を解決しようとする良いイニシアチブ:)。あなたはとても近いです！実際には、すべてのシートをループしてから 2 を使用する必要があります.Finds。1 つは会社名用で、もう 1 つは製品用です。

このコードを参照してください（試行およびテスト済み）

私が書いたコメントを読んでください。

Option Explicit

Sub Sample()
    Dim wsP As Worksheet, ws As Worksheet
    Dim lRow As Long, i As Long
    Dim aCell As Range, bCell As Range

    '~~> Replace below with the name of the sheet which has the products
    Set wsP = Sheets("Product")

    '~~> Loop through every sheet
    For Each ws In ThisWorkbook.Sheets
        '~~> Ensure that we ignore the product sheet
        If ws.Name <> wsP.Name Then
            With ws
                '~~> Get the last row of Col A in ws
                lRow = .Range("A" & .Rows.Count).End(xlUp).Row

                '~~> Check the rows in product sheet to find which column
                '~~> has the Company name I am assuming that the company
                '~~> names are in row 1 unlike row 2 in your screenshot
                '~~> If it is actually 2 then change Rows(1) to Rows(2)
                Set aCell = wsP.Rows(1).Find(What:=ws.Name, LookIn:=xlValues, _
                LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
                MatchCase:=False, SearchFormat:=False)

                '~~> Check if company name is found
                If Not aCell Is Nothing Then
                    For i = 2 To lRow

                        '~~> Check Column 1 to find the product
                        Set bCell = wsP.Columns(1).Find(What:=ws.Range("A" & i).Value, _
                        LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, _
                        SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

                        '~~> If found then pick up the value from the relevant column
                        If Not bCell Is Nothing Then _
                        ws.Range("B" & i).Value = wsP.Cells(bCell.Row, aCell.Column).Value

                    Next i
                Else
                    MsgBox "Company Name not found. Moving on to the next sheet"
                End If
            End With
        End If
    Next ws

    MsgBox "Done"
End Sub
于 2012-08-10T10:52:21.683 に答える