[已解决]如何修改成可移动路径，谢谢

筱灵之心

跨工作簿逻辑性搜索.zip (760 Bytes, 下载次数: 7)

2013-6-21 21:58 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-6-21 22:14

直接通过对话框选择路径。

1. Sub 查找()
   
2.     Application.ScreenUpdating = False    '禁止刷屏
   
3.     Application.DisplayAlerts = False    '禁止弹出对话框
   
4.     Range("c4:e" & [c65536].End(3).Row + 10).ClearContents    '清空要写入数据的区域
   
5. 
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .AllowMultiSelect = False
   
8.         If .Show = -1 Then
   
9.             mp = .SelectedItems(1) & Application.PathSeparator
   
10.         Else
    
11.             MsgBox "没有选择要查找的文件夹，退出"
    
12.             Exit Sub
    
13.         End If
    
14.     End With
    
15.     mf = Dir(mp & "粘焊车间（数据模板）.xls")    '文件
    
16.     Set dk = Workbooks.Open(mp & mf)    '打开粘焊车间（数据模板）.xls
    
17.     '把打开的文件有数据区域写入数组（是动态的，可以随意添加行）
    
18.     arr1 = dk.Sheets(1).Range("a2:e" & dk.Sheets(1).[b65536].End(3).Row)
    
19.     '把粘焊文件有数据区域写入数组（是动态的，可以随意添加行）
    
20.     arr2 = ThisWorkbook.Sheets(1).Range("a4:b" & ThisWorkbook.Sheets(1).[b65536].End(3).Row)
    
21.     For i = 1 To UBound(arr2)    '在数组arr1的下限与上限之间循环
    
22.         For j = 1 To UBound(arr1)    '在数组arr2的下限与上限之间循环
    
23.             If arr1(j, 2) = arr2(i, 2) Then    '如果流程票号相等
    
24.                 Cells(i + 3, 3) = arr1(j, 3): Cells(i + 3, 4) = arr1(j, 4): Cells(i + 3, 5) = arr1(j, 5)    '写入相应数据
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     dk.Close True    '关闭文件
    
29.     Application.ScreenUpdating = True    '允许刷屏
    
30.     Application.DisplayAlerts = True    '允许弹出对话框
    
31. End Sub

复制代码

跳转到最佳答案楼层

hwc2ycy

直接通过对话框选择路径。

1. Sub 查找()
   
2.     Application.ScreenUpdating = False    '禁止刷屏
   
3.     Application.DisplayAlerts = False    '禁止弹出对话框
   
4.     Range("c4:e" & [c65536].End(3).Row + 10).ClearContents    '清空要写入数据的区域
   
5. 
   
6.     With Application.FileDialog(msoFileDialogFolderPicker)
   
7.         .AllowMultiSelect = False
   
8.         If .Show = -1 Then
   
9.             mp = .SelectedItems(1) & Application.PathSeparator
   
10.         Else
    
11.             MsgBox "没有选择要查找的文件夹，退出"
    
12.             Exit Sub
    
13.         End If
    
14.     End With
    
15.     mf = Dir(mp & "粘焊车间（数据模板）.xls")    '文件
    
16.     Set dk = Workbooks.Open(mp & mf)    '打开粘焊车间（数据模板）.xls
    
17.     '把打开的文件有数据区域写入数组（是动态的，可以随意添加行）
    
18.     arr1 = dk.Sheets(1).Range("a2:e" & dk.Sheets(1).[b65536].End(3).Row)
    
19.     '把粘焊文件有数据区域写入数组（是动态的，可以随意添加行）
    
20.     arr2 = ThisWorkbook.Sheets(1).Range("a4:b" & ThisWorkbook.Sheets(1).[b65536].End(3).Row)
    
21.     For i = 1 To UBound(arr2)    '在数组arr1的下限与上限之间循环
    
22.         For j = 1 To UBound(arr1)    '在数组arr2的下限与上限之间循环
    
23.             If arr1(j, 2) = arr2(i, 2) Then    '如果流程票号相等
    
24.                 Cells(i + 3, 3) = arr1(j, 3): Cells(i + 3, 4) = arr1(j, 4): Cells(i + 3, 5) = arr1(j, 5)    '写入相应数据
    
25.             End If
    
26.         Next
    
27.     Next
    
28.     dk.Close True    '关闭文件
    
29.     Application.ScreenUpdating = True    '允许刷屏
    
30.     Application.DisplayAlerts = True    '允许弹出对话框
    
31. End Sub

复制代码

筱灵之心

hwc2ycy 发表于 2013-6-21 22:14
直接通过对话框选择路径。

能不能改成不要每次都需要选择在哪里呢

hwc2ycy

可以把获得的路径存工作表里，然后每次检测，如果是空值就再让选择。

筱灵之心

hwc2ycy 发表于 2013-6-21 22:38
可以把获得的路径存工作表里，然后每次检测，如果是空值就再让选择。

不明白

筱灵之心

hwc2ycy 发表于 2013-6-21 22:38
可以把获得的路径存工作表里，然后每次检测，如果是空值就再让选择。

顺便帮我把另外两个车间也设一下好吗？我实在是看不懂，好好学习，谢谢 2013年7月份数据模板.zip (417.89 KB, 下载次数: 1)

2013-6-21 22:51 上传

点击文件名下载附件 不要经常提示文件在哪里的窗口哦！

hwc2ycy

1.     Application.ScreenUpdating = False    '禁止刷屏
   
2.     Application.DisplayAlerts = False    '禁止弹出对话框
   
3.     Range("c4:e" & [c65536].End(3).Row + 10).ClearContents    '清空要写入数据的区域
   
4. 
   
5.     If Len(Cells(Rows.Count, 1)) = 0 Then
   
6. 
   
7.         With Application.FileDialog(msoFileDialogFolderPicker)
   
8.             .AllowMultiSelect = False
   
9.             If .Show = -1 Then
   
10.                 mp = .SelectedItems(1) & Application.PathSeparator
    
11.                 Cells(Rows.Count, 1).Value = mp
    
12.             Else
    
13.                 MsgBox "没有选择要查找的文件夹，退出"
    
14.                 Exit Sub
    
15.             End If
    
16.         End With
    
17.     Else
    
18.         mp = Cells(Rows.Count, Columns.Count).Value
    
19.     End If
    
20. 
    
21.     mf = Dir(mp & "粘焊车间（数据模板）.xls")    '文件
    
22.     Set dk = Workbooks.Open(mp & mf)    '打开粘焊车间（数据模板）.xls
    
23.     '把打开的文件有数据区域写入数组（是动态的，可以随意添加行）
    
24.     arr1 = dk.Sheets(1).Range("a2:e" & dk.Sheets(1).[b65536].End(3).Row)
    
25.     '把粘焊文件有数据区域写入数组（是动态的，可以随意添加行）
    
26.     arr2 = ThisWorkbook.Sheets(1).Range("a4:b" & ThisWorkbook.Sheets(1).[b65536].End(3).Row)
    
27.     For i = 1 To UBound(arr2)    '在数组arr1的下限与上限之间循环
    
28.         For j = 1 To UBound(arr1)    '在数组arr2的下限与上限之间循环
    
29.             If arr1(j, 2) = arr2(i, 2) Then    '如果流程票号相等
    
30.                 Cells(i + 3, 3) = arr1(j, 3): Cells(i + 3, 4) = arr1(j, 4): Cells(i + 3, 5) = arr1(j, 5)    '写入相应数据
    
31.             End If
    
32.         Next
    
33.     Next
    
34.     dk.Close True    '关闭文件
    
35.     Application.ScreenUpdating = True    '允许刷屏
    
36.     Application.DisplayAlerts = True    '允许弹出对话框
    
37. End Sub

复制代码