循环查找并将相应的值从一个工作簿打印到VBA中的活动工作簿
我是新手到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
真的不知道的范围（S）。
有很多方法可以达到你想要的。 这里有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