2

VBA初心者ですので、よろしくお願いします。次のデータを含むワークブックがコンピューターに保存されています。

Name    Value
A            6
B            10
C            13
D            9
E            10
F            17
G            6
H            6

アクティブなワークブックには、次のデータがあります。

A
C
B
D
E

最初のワークブックをループして、現在のワークブックにそれぞれの値を出力する必要があります。これが私ができたことです：

Option Explicit

Sub Compare()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Group As Range, Mat As Range
    Dim CurCell_1 As Range, CurCell_2 As Range

    Application.ScreenUpdating = False

    Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select the file")
    If Ret1 = False Then Exit Sub

    Set wb1 = app.Workbooks.Open(Ret1)
    Set wb2 = app.ActiveWorkbook


    Set ws1 = wb1.Sheets("Sheet1")
    Set ws2 = wb2.Sheets("Sheet2")

    For Each Group In ws1.Range("A2:A9")
        Set CurCell_2 = ws2.Range("B2:B6")
        For Each Mat In ws1.Range("B2:B9")
            Set CurCell_1 = ws1.Cells(Mat.Row, Group.Column)
            If Not IsEmpty(CurCell_1) Then
                CurCell_2.Value = CurCell_1.Value
                Set CurCell_2 = CurCell_2.Offset(1)
            End If
        Next
    Next

    Application.ScreenUpdating = True
End Sub

範囲については本当にわかりません。

4

1 に答える 1

1

やりたいことを実現する方法はたくさんあります。ここに3つの方法があります...

方法 1 (使用.Find)

あなたもこれを見たいと思うかもしれません。

Option Explicit

Sub Compare()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Group As Range, Mat As Range, aCell As Range
    Dim lRow As Long, i As Long
    Dim Ret

    Application.ScreenUpdating = False

    Ret = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select the file")

    If Ret = False Then Exit Sub

    Set wb1 = Workbooks.Open(Ret)
    Set wb2 = ThisWorkbook


    Set ws1 = wb1.Sheets("Sheet1")
    Set ws2 = wb2.Sheets("Sheet2")

    With ws2
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        For i = 1 To lRow
            Set aCell = ws1.Columns(1).Find(What:=.Range("A" & i).Value, _
                                                         LookIn:=xlValues, _
                                                         LookAt:=xlWhole, _
                                                         SearchOrder:=xlByRows, _
                                                         SearchDirection:=xlNext, _
                                                         MatchCase:=False, _
                                                         SearchFormat:=False)
            If Not aCell Is Nothing Then
                .Range("B" & i).Value = aCell.Offset(, 1).Value
            End If
        Next i
    End With

    wb1.Close (False)

    Application.ScreenUpdating = True
End Sub

方法 2 (使用Loops)

Option Explicit

Sub Compare()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Group As Range, Mat As Range
    Dim lRowWs1 As Long, lRoWws2 As Long, i As Long, j As Long
    Dim Ret

    Application.ScreenUpdating = False

    Ret = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select the file")

    If Ret = False Then Exit Sub

    Set wb1 = Workbooks.Open(Ret)
    Set wb2 = ThisWorkbook


    Set ws1 = wb1.Sheets("Sheet1")
    Set ws2 = wb2.Sheets("Sheet38")

    With ws2
        lRoWws2 = .Range("A" & .Rows.Count).End(xlUp).Row
        lRowWs1 = ws1.Range("A" & ws1.Rows.Count).End(xlUp).Row

        For i = 1 To lRoWws2
            For j = 1 To lRowWs1
                If .Range("A" & i).Value = ws1.Range("A" & j).Value Then
                    .Range("B" & i).Value = ws1.Range("B" & j).Value
                    Exit For
                End If
            Next j
        Next i
    End With

    wb1.Close (False)

    Application.ScreenUpdating = True
End Sub

方法 3 (Vlookupコードで数式を使用)

Option Explicit

Sub Compare()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim Group As Range, Mat As Range
    Dim lRow As Long
    Dim FName As String
    Dim Ret

    Application.ScreenUpdating = False

    Ret = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select the file")

    If Ret = False Then Exit Sub

    Set wb1 = Workbooks.Open(Ret)
    Set wb2 = ThisWorkbook

    FName = wb1.Name

    Set ws1 = wb1.Sheets("Sheet1")
    Set ws2 = wb2.Sheets("Sheet38")

    With ws2
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row

        .Range("B1:B" & lRow).Formula = "=VLOOKUP(A1,[" & FName & "]Sheet1!$A:$B,2,0)"
        .Range("B1:B" & lRow).Value = .Range("B1:B" & lRow).Value
    End With

    wb1.Close (False)

    Application.ScreenUpdating = True
End Sub
于 2013-10-24T11:26:41.503 に答える