Question

我是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

真的不确定范围。

Answer 1

有很多方法可以达到你想要的效果。这有三种方式......

第1天（使用.Find）

您可能也希望看到THIS。

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

WAY 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

循环以查找和打印从一个工作簿到VBA中的活动工作簿的相应值

1 个答案: