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 回答