[已解决]帮忙写段代码(工资表导入)

opelwang

说明：
1、日报表的工作薄命名格式是日期：(2011-08-01、2011-08-02.......2011-08-31)，中间可能有断号的现象；要取的数据在日报表工作薄花名册工作表的AL1:BF7区域，固定。
===================
2、在汇总表做个按钮，点击下，弹窗：请输入需要导入工资的报表日期段 如输入：1-10，则是导入1-10号的报表，共10天，如果中间有断号（如：2011-08-06没有），完成后，提示：未找到报表：2011-08-06  对应条件：日期、机台、项目，日报表存放于固定区域，如：D:\text\
===================
3、全部导放完成后，加个提示动作：工资导入完成，用时？秒。如果大于60秒，则单位转换：如：1分20秒。如果小于60秒，则无需转换。如：35秒。

附件： 汇总.rar (37.4 KB, 下载次数: 30)

2011-8-13 20:05 上传

点击文件名下载附件

期待您的帮忙~~，悬赏10金币，一点心意，还望笑纳~~~

‘

最佳答案

月排行榜 / 总排行榜

1970-1-1 08:00

跳转到最佳答案楼层

fjmxwrs

回复 opelwang 的帖子

1. Sub 数据合并()
   
2. Dim Qssj, Lj As String, Wj As String, Xm As String, Sj As Double
   
3. Dim Rq As Long, Xrl As Long, Xrh As Long, Qsh As Long, i3 As Date
   
4. Dim i1 As String, i2 As String, ttt As String, k As Long
   
5. On Error Resume Next
   
6. Qssj = Timer
   
7. Lj = ThisWorkbook.Path & "\00"
   
8. i1 = InputBox("请输入开始日期：d")
   
9. If i1 = "" Then Exit Sub
   
10. i2 = InputBox("请输入结束日期：d")
    
11. If i2 = "" Then Exit Sub
    
12. i3 = Range("D2").Value
    
13. Application.ScreenUpdating = False
    
14. Range("D3:AI59").ClearContents
    
15. For x = i1 To i2
    
16. tt = Format(i3, "yyyy-mm") & "-" & Format(x, "00")
    
17. Wj = Dir(Lj & tt & ".xls")
    
18. If Wj = "" Then
    
19. If ttt = "" Then
    
20. ttt = tt
    
21. Else
    
22. If k Mod 3 = 0 Then
    
23. ttt = ttt & Chr(10) & tt
    
24. Else
    
25. ttt = ttt & ", " & tt
    
26. End If
    
27. End If
    
28. k = k + 1
    
29. GoTo aa
    
30. End If
    
31. Workbooks.Open (Lj & Wj)
    
32. Rq = Mid(tt, 9, 2)
    
33. Xrl = Rq + 3
    
34. With ActiveWorkbook.Sheets("花名冊")
    
35. For i = 40 To 55
    
36. Qsh = Range("B2:B50").Find(.Cells(1, i)).Row
    
37. For j = 2 To 4
    
38. Sj = .Cells(j, i)
    
39. Xm = .Cells(j, 39)
    
40. Xrh = Qsh + j - 2
    
41. Cells(Xrh, Xrl) = Cells(Xrh, Xrl) + Sj
    
42. Cells(Xrh, 35) = Cells(Xrh, 35) + Sj
    
43. Next j
    
44. Next i
    
45. End With
    
46. ActiveWorkbook.Close True
    
47. aa:
    
48. Next x
    
49. Application.ScreenUpdating = True
    
50. If ttt = "" Then
    
51. MsgBox "共用时" & Round((Timer - Qssj), 0) & "秒!"
    
52. Else
    
53. MsgBox ttt & Chr(10) & k & "个文件不存在" & Chr(10) & "共用时" & Round((Timer - Qssj), 0) & "秒!"
    
54. End If
    
55. End Sub
    

复制代码

这是你要的，测试通过

蓝桥玄霜

楼主不会写代码？怎么我看到过你在研究进程的问题？
建议搜索多工作簿汇总。

opelwang

蓝桥玄霜 发表于 2011-8-7 13:08
楼主不会写代码？怎么我看到过你在研究进程的问题？
建议搜索多工作簿汇总。

让：蓝版见笑了，那是在网上找到的一段代码，测试了下，感觉蛮好玩的，VBA都能列出Windows进程~~
就是缺少了一个路径，这才发贴到论坛的。
真的不会写代码~~

wayy

系统类和要求太多类的，建议找这里给做，包你满意：
http://shop62741887.taobao.com/

opelwang

这个是收费的呀,,,,

opelwang

1楼的问题已经更新，不是原贴要求了。
敬请指点，谢谢~

fjmxwrs

跟踪来学习

fjmxwrs

1. Sub 数据合并()
   
2.     Dim Qssj, Lj As String, Wj As String, Xm As String, Sj As Double
   
3.     Dim Rq As Long, Xrl As Long, Xrh As Long, Qsh As Long, i3 As Long, i4 As Long
   
4.     Dim i1 As String, i2 As String
   
5.     On Error Resume Next
   
6.     Qssj = Timer
   
7.     Lj = ThisWorkbook.Path & "\00"
   
8.     i1 = InputBox("请输入开始日期：yyyy-m-d")
   
9.     If i1 = "" Then Exit Sub
   
10.     i2 = InputBox("请输入结束日期：yyyy-m-d")
    
11.     If Len(i2) = 0 Then Exit Sub
    
12.     i3 = Val(Format(i1, "d"))
    
13.     i4 = Val(Format(i2, "d"))
    
14.     Application.ScreenUpdating = False
    
15.     Range("D3:AI59").ClearContents
    
16.     For x = i3 To i4
    
17.         tt = Format(i1, "yyyy-mm") & "-" & Format(x, "00")
    
18.         Wj = Dir(Lj & tt & ".xls")
    
19.         Workbooks.Open (Lj & Wj)
    
20.         Rq = Mid(tt, 9, 2)
    
21.         Xrl = Rq + 3
    
22.         With ActiveWorkbook.Sheets("花名冊")
    
23.             For i = 40 To 55
    
24.                 Qsh = Range("B2:B50").Find(.Cells(1, i)).Row
    
25.                 For j = 2 To 7
    
26.                     Sj = .Cells(j, i)
    
27.                     Xm = .Cells(j, 39)
    
28.                     Select Case Xm
    
29.                         Case "生產數量"
    
30.                             Xrh = Qsh
    
31.                             Cells(Xrh, Xrl) = Cells(Xrh, Xrl) + Sj
    
32.                             Cells(Xrh, 35) = Cells(Xrh, 35) + Sj
    
33.                         Case "生產時間"
    
34.                             Xrh = Qsh + 1
    
35.                             Cells(Xrh, Xrl) = Cells(Xrh, Xrl) + Sj
    
36.                             Cells(Xrh, 35) = Cells(Xrh, 35) + Sj
    
37.                         Case "生產面積"
    
38.                             Xrh = Qsh + 2
    
39.                             Cells(Xrh, Xrl) = Cells(Xrh, Xrl) + Sj
    
40.                             Cells(Xrh, 35) = Cells(Xrh, 35) + Sj
    
41.                     End Select
    
42.                 Next j
    
43.             Next i
    
44.         End With
    
45.         ActiveWorkbook.Close True
    
46.     Next x
    
47.     Application.ScreenUpdating = True
    
48.     MsgBox "共用时" & Round((Timer - Qssj), 0) & "秒!"
    
49. End Sub

复制代码

opelwang

非常感谢fjmxwrs版主帮忙与指点~~~
8楼的代码，效果不错；仔细测试了下，还有2点需要帮忙完善下：

1、把这个框中输入的日期格式由：yyyy-m-d  改为：m-d
2、输入开始日期（2011-8-1）与结束日期（2011-8-6），如果指定的文件夹内只有(2011-8-1.....2011-8-5)这五个工作薄，则在更新完成后，直接关闭了当前工作表，忽略了以下代码的运行：

1.     Next x
   
2.     Application.ScreenUpdating = True
   
3.     MsgBox "共用时" & Round((Timer - Qssj), 0) & "秒!"

复制代码

以第2点为例，实际要求是，数据导入完成后，弹窗提示：您选择导入6份报表，实际只找到5份报表；
                                                                            没有找到【2011-8-6】工作薄，请确定文件是否存放正确？
点击确定后，然后再：Next x  ......
‘