VBA 按条件查找并提取数据
比如sheet1表要从sheet2表中提取数据：
将如下代码复制到sheet1的代码编辑窗口下：
Private Sub qq() Dim i As Integer, j As Integer
For i = 2 To 10000 Step 1
If Sheet1.Cells(i, 1) = \"\" And Sheet1.Cells(i + 1) = \"\" And Sheet1.Cells(i + 2) = \"\" Then Exit For
For j = 1 To 10000 Step 1
If Sheet1.Cells(j, 1) = \"\" And Sheet1.Cells(j + 1) = \"\" And Sheet1.Cells(j + 2) = \"\" Then Exit For
If Sheet1.Cells(i, 1) = Sheet2.Cells(j, 1) Then
If Sheet1.Cells(i, 2) = \"\" Then
Sheet1.Cells(i, 2) = Sheet2.Cells(j, 2)
Sheet1.Cells(i, 3) = Sheet2.Cells(j, 3)
Sheet1.Cells(i, 4) = Sheet2.Cells(j, 4)
End If End If Next j Next i End Sub '运行即可
'根据提问者的问题补充，我又做了如下代码，放于表B的工作表代码编辑窗口下：
'比如表A的工作表名称是：表A.xls，数据都A、B、C、D四列中
Private Sub qq() Dim i As Integer, j As Integer
For i = 2 To 10000 Step 1
If Cells(i, 1) = \"\" And Cells(i + 1,1) = \"\" And Cells(i + 2,1) = \"\" Then Exit For
For j = 1 To 10000 Step 1
If GetValue(\"D:\\\表A.xls\
GetValue(\"D:\\\表A.xls\
GetValue(\"D:\\\表A.xls\
If Cells(i, 1) = GetValue(\"D:\\\表A.xls\
If Cells(i, 2) = \"\" Then
Cells(i, 2) = GetValue(\"D:\\\表A.xls\
Cells(i, 3) = GetValue(\"D:\\\表A.xls\
Cells(i, 4) = GetValue(\"D:\\\表A.xls\
End If
End If
Next j
Next i
End Sub
'创建函数,从关闭的工作薄返回值
Private Function GetValue(path, filename, sheet, ref) Dim MyPath As String
'确定文件是否存在
If Right(path, 1) <> \"\\\" Then path = path & \"\\\"
If Dir(path & filename) = \"\" Then
GetValue = \"File Not Found\"
Exit Function
End If
'创建公式
MyPath = \"'\" & path & \"[\" & filename & Range(ref).Range(\"A1\").Address(, , xlR1C1)
& sheet & \"'!\" & \"]\"
'执行EXCEL4宏函数
GetValue = Application.ExecuteExcel4Macro(MyPath)
End Function
'函数参数说明
'-----------------------------------------------------------------
'path：文件路径
'filename：文件名称
'sheet：工作表名称
'ref： 单元格区域
