[已解决]生产计划明细表日期导入

che_dream

A,B,F,G,H,J列与《生产计划明细表.已完成》中G,I,A,B,C,J列一一对应，五列同时满足唯一性，现在我想把《已完成》表中的完成日期相应导入《12345》表中，用VBA，谢谢！

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2012-10-13 09:49

(, 下载次数: 35)

上传

点击文件名下载附件

跳转到最佳答案楼层

hwc2ycy

MARK，回家再练。

hwc2ycy

1. Sub 导入日期()
   
2.     Dim wb As Workbook
   
3.     Dim sPath As String
   
4.     Dim sFilename As String
   
5.     Dim sWorkbookname As String
   
6.     Dim arr, dic, arrRst
   
7.     Dim irow, i, j, k, sKey As String
   
8.     Dim arrCol
   
9.     Dim test1, test2
   
10.     On Error Resume Next
    
11.     Application.ScreenUpdating = False
    
12.     sFilename = "生产计划明细表.xls"
    
13.     sPath = ThisWorkbook.Path & "" & sFilename
    
14.     sWorkbookname = "生产计划明细表"
    
15.     If Dir(sPath) = "" Then
    
16.         MsgBox sFilename & "文件不存在"
    
17.         Exit Sub
    
18.     End If
    
19.     Set wb = Workbooks.Item(sFilename)
    
20.     If wb Is Nothing Then
    
21.         Workbooks.Open Filename:=sPath, ReadOnly:=True
    
22.         Worksheets(1).Activate
    
23.     Else
    
24.         Workbooks(sFilename).Activate
    
25.         Worksheets(1).Activate
    
26.     End If
    
27.     'arr = Range("a3").CurrentRegion    '方法一取当前区域
    
28.     irow = Range("a3").End(xlDown).Row      '方法二，先旧最后一行数据行，然后再整行
    
29.     arr = Range("a4:q" & irow)
    
30.     ReDim arrRst(1 To UBound(arr), 1 To 1)  '根据行数重新定义数组大小
    
31.     Set dic = CreateObject("scripting.dictionary")
    
32.     arrCol = Array(1, 2, 3, 7, 9, 10)
    
33.     For i = 1 To UBound(arr)
    
34.         sKey = ""
    
35.         For j = 0 To UBound(arrCol)
    
36.             sKey = sKey & arr(i, arrCol(j)) & "|"
    
37.         Next
    
38.         dic(sKey) = arr(i, 15)
    
39.         'Debug.Print sKey & "  " & dic(sKey)
    
40.     Next
    
41.     Erase arr
    
42.     ActiveWorkbook.Close SaveChanges:=False
    
43.     ThisWorkbook.Activate
    
44.     Worksheets("12345").Select
    
45.     'arr = Range("a3").CurrentRegion    '方法一取当前区域
    
46.     irow = Range("a3").End(xlDown).Row      '方法二，先旧最后一行数据行，然后再整行
    
47.     arr = Range("a4:l" & irow)
    
48.     arrCol = Array(6, 7, 8, 1, 2, 10)
    
49.     For i = 1 To UBound(arr)
    
50.         sKey = ""
    
51.         For j = 0 To UBound(arrCol)
    
52.             sKey = sKey & arr(i, arrCol(j)) & "|"
    
53.         Next
    
54.         arrRst(i, 1) = Format(dic(sKey), "M月d日")
    
55.         'Debug.Print sKey & "  " & Format(dic(sKey), "M月d日")
    
56.     Next
    
57.    
    
58.     Range("k4").Resize(dic.Count, 1) = arrRst
    
59. End Sub

复制代码

hwc2ycy

对了，你除件里的文件名为"生产计划明细表 .xls"，文件名里有个空格，我直接改了名。
你测试的时候也记得改下文件名吧。

另外，在123.XLS里我已经添加了一个导入日期按钮，在点按钮时最好能关闭生产计划明细表文件吧。

结果写入的日期列我改了整列的自定义格式为M月D日形式。

hwc2ycy

新建文件夹 (2).rar (29.46 KB, 下载次数: 35)

2012-10-12 20:26 上传

点击文件名下载附件

che_dream

hwc2ycy 发表于 2012-10-12 20:26
对了，你除件里的文件名为"生产计划明细表 .xls"，文件名里有个空格，我直接改了名。
你测试的时候也记得改 ...

上午好，万分感谢你的帮忙，早上测试了一下，有两个小问题，一个是我的生产计划明细表里除了“已完成”以外还有其他的表，我把其他表删除了测试可以，所以要精确到“已完成”表中，二个 是在“12345”表中从766行开始显示#N/A，求解，谢谢！

che_dream

hwc2ycy 发表于 2012-10-12 20:26

刚刚我看了一下，我的“已完成”表中是765行，但我的12345表中是1263行，就是说这两个表中的行数不一样。

hwc2ycy

che_dream 发表于 2012-10-13 08:39
上午好，万分感谢你的帮忙，早上测试了一下，有两个小问题，一个是我的生产计划明细表里除了“已完成”以 ...

这个可以改下。样本里时我看只有一个表，就没有定位了。

hwc2ycy

显示NA，应该是两个表的信息有不一致的地方。
因为我是根据那6列关键值来核实的。
要不你把你的表压缩上传，我看看。

hwc2ycy

1. Sub 导入日期()
   
2.     Dim wb As Workbook
   
3.     Dim sPath As String
   
4.     Dim sFilename As String
   
5.     Dim sWorkbookname As String
   
6.     Dim arr, dic, arrRst
   
7.     Dim irow, i, j, k, sKey As String
   
8.     Dim arrCol
   
9.     Dim sShtName$
   
10.     On Error Resume Next
    
11.     Application.ScreenUpdating = False
    
12.     sFilename = "生产计划明细表.xls"
    
13.     sPath = ThisWorkbook.Path & "" & sFilename
    
14.     sWorkbookname = "生产计划明细表"
    
15.     sShtName = "已完成"
    
16.     If Dir(sPath) = "" Then
    
17.         MsgBox sFilename & "文件不存在"
    
18.         Exit Sub
    
19.     End If
    
20.     Set wb = Workbooks.Item(sFilename)
    
21.     If wb Is Nothing Then
    
22.         Workbooks.Open Filename:=sPath, ReadOnly:=True
    
23.         Worksheets(sShtName).Activate
    
24.     Else
    
25.         Workbooks(sFilename).Activate
    
26.         Worksheets(sShtName).Activate
    
27.     End If
    
28.     'arr = Range("a3").CurrentRegion    '方法一取当前区域
    
29.     irow = Range("a3").End(xlDown).Row      '方法二，先旧最后一行数据行，然后再整行
    
30.     Debug.Print "数据源工作表最末行是" & irow
    
31.     arr = Range("a4:q" & irow)
    
32.     ReDim arrRst(1 To UBound(arr), 1 To 1)  '根据行数重新定义数组大小
    
33.     Set dic = CreateObject("scripting.dictionary")
    
34.     arrCol = Array(1, 2, 3, 7, 9, 10)
    
35.     For i = 1 To UBound(arr)
    
36.         sKey = ""
    
37.         For j = 0 To UBound(arrCol)
    
38.             sKey = sKey & arr(i, arrCol(j)) & "|"
    
39.         Next
    
40.         dic(sKey) = arr(i, 15)
    
41.         Debug.Print "源表读取 " & sKey & "  " & dic(sKey)
    
42.     Next
    
43.     Erase arr
    
44.     ActiveWorkbook.Close SaveChanges:=False
    
45.     ThisWorkbook.Activate
    
46.     Worksheets("12345").Select
    
47.     'arr = Range("a3").CurrentRegion    '方法一取当前区域
    
48.     irow = Range("a3").End(xlDown).Row      '方法二，先旧最后一行数据行，然后再整行
    
49.     Debug.Print vbCr
    
50.     Debug.Print "目标工作表的数据末行是" & irow
    
51.     arr = Range("a4:l" & irow)
    
52.     arrCol = Array(6, 7, 8, 1, 2, 10)
    
53.     For i = 1 To UBound(arr)
    
54.         sKey = ""
    
55.         For j = 0 To UBound(arrCol)
    
56.             sKey = sKey & arr(i, arrCol(j)) & "|"
    
57.         Next
    
58.         arrRst(i, 1) = Format(dic(sKey), "M月d日")
    
59.         Debug.Print "目标数据读取 " & sKey & "  " & dic(sKey)
    
60.     Next
    
61.    
    
62.     Range("k4").Resize(dic.Count, 1) = arrRst
    
63. End Sub

复制代码