查找另一个相同格式的表，如果销售订单一样，而且印刷设备为空，则提取对应的印刷设备，印刷方式，工艺备注到现在的表中。
销售订单 印刷设备 印刷方式 工艺备注
13256194 机印 打底 123
13237942 手印 不打底 456
13242057 提花 打底 334
13242233 机印 不打底 333
13269904
13269972
13270786
13279870
要采用VBA，在不打开另一个工作簿的前提下，提取数据。
假设表A存放在D:\原始文件，表B存放在E:\跟踪表。
两个表的格式一样，现在在表B设定宏，查找表A，如果表A中，销售订单和表A一样，而且印刷设备为空，则提取对应的印刷设备，印刷方式，工艺备注到表B中。
不需要VBA，只需要vlookup函数就可以了，比如根据销售订单号（在E1）找印刷设备，可以设这样的公式：=VLOOKUP(E1,A:D,2,0)，其他的类推（比如=VLOOKUP(E1,A:D,3,0)）就可以了。
温馨提示：答案为网友推荐，仅供参考
第1个回答 2011-11-18
为何要放在两个工作簿呢？ 直接把两个工作表放在一个工作簿 用vlookup解决就可以了啊
复杂的问题要简单化
用vba提取数据在不同的工作簿里会影响运行速度的追问
复杂的问题要简单化
用vba提取数据在不同的工作簿里会影响运行速度的追问
工作需要，要用不同的表，而且表数据也是非常大，有一个是共享的，如果放在一起运行会更慢。
第2个回答 2011-11-18
另外一个表格印刷设备是不是一定是非空列，如果是的话直接使用VLOOKUP就好了
第3个回答 2011-11-18
比如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", "Sheet1", "A" & j) = 0 And _
GetValue("D:\", "表A.xls", "Sheet1", "A" & j + 1) = 0 And _
GetValue("D:\", "表A.xls", "Sheet1", "A" & j + 2) = 0 Then Exit For
If Cells(i, 1) = GetValue("D:\", "表A.xls", "Sheet1", "A" & j) Then
If Cells(i, 2) = "" Then
Cells(i, 2) = GetValue("D:\", "表A.xls", "Sheet1", "B" & j)
Cells(i, 3) = GetValue("D:\", "表A.xls", "Sheet1", "C" & j)
Cells(i, 4) = GetValue("D:\", "表A.xls", "Sheet1", "D" & j)
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 & "]" & sheet & "'!" & Range(ref).Range("A1").Address(, , xlR1C1)
'执行EXCEL4宏函数
GetValue = Application.ExecuteExcel4Macro(MyPath)
End Function
'函数参数说明
'-----------------------------------------------------------------
'path：文件路径
'filename：文件名称
'sheet：工作表名称
'ref： 单元格区域
'-----------------------------------------------------------------
'好用的话，还希望采纳并加分哦!!!!!!!!!!!!!!!!!!!!!!追问
将如下代码复制到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", "Sheet1", "A" & j) = 0 And _
GetValue("D:\", "表A.xls", "Sheet1", "A" & j + 1) = 0 And _
GetValue("D:\", "表A.xls", "Sheet1", "A" & j + 2) = 0 Then Exit For
If Cells(i, 1) = GetValue("D:\", "表A.xls", "Sheet1", "A" & j) Then
If Cells(i, 2) = "" Then
Cells(i, 2) = GetValue("D:\", "表A.xls", "Sheet1", "B" & j)
Cells(i, 3) = GetValue("D:\", "表A.xls", "Sheet1", "C" & j)
Cells(i, 4) = GetValue("D:\", "表A.xls", "Sheet1", "D" & j)
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 & "]" & sheet & "'!" & Range(ref).Range("A1").Address(, , xlR1C1)
'执行EXCEL4宏函数
GetValue = Application.ExecuteExcel4Macro(MyPath)
End Function
'函数参数说明
'-----------------------------------------------------------------
'path：文件路径
'filename：文件名称
'sheet：工作表名称
'ref： 单元格区域
'-----------------------------------------------------------------
'好用的话，还希望采纳并加分哦!!!!!!!!!!!!!!!!!!!!!!追问
要求达到了，但是运行的速度非常慢，有没有可能采用ADO来提取数据。
追答不好意思哦，这个还真的不会哦！
本回答被提问者采纳