[已解决]用EXCEL VBA复制粘贴

2198596388

各位高手、老师帮帮忙，怎样把文件夹中20150320~20150413文档中的内容复制粘贴到工作簿中sheets("存档")工作表里呢？（按文档时间先后顺序复制粘贴）    附件 文件夹.rar (292.64 KB, 下载次数: 14)

2015-7-27 16:07 上传

点击文件名下载附件    先谢谢了！

最佳答案

月排行榜 / 总排行榜

gufengaoyue

2015-7-28 12:49

2198596388 发表于 2015-7-27 18:28
辛苦老师！先谢谢老师了！看起来有点复杂，老师能简单点吗？
我的效果要求是：把文件夹中的一部分文档， ...

1. Sub 方法一()
   
2. On Error Resume Next
   
3. Dim fName, arr$(1 To 4 ^ 10, 1 To 2), b, brr, crr As Variant, x&, y&
   
4. x = InputBox("开始日期", , 20150318)
   
5. y = InputBox("结束日期", , 20150320)
   
6. If x = 0 Or y = 0 Or Err.Number <> 0 Then Exit Sub
   
7. fName = Dir(ThisWorkbook.Path & "")
   
8. Do Until fName = ""
   
9.     If UCase(Right(fName, 3)) = "TXT" Then
   
10.         a = a + 1:
    
11.         arr(a, 1) = fName
    
12.         arr(a, 2) = Val(Left(fName, 8))
    
13.     End If
    
14.     fName = Dir()
    
15. Loop
    
16. BubbleSort2 arr, a
    
17. Cells.Clear
    
18. For i = 1 To a
    
19.     If arr(i, 2) >= x And arr(i, 2) <= y Then
    
20.     Open ThisWorkbook.Path & "" & arr(i, 1) For Input As #1
    
21.         brr = Split(Trim(StrConv(InputB(LOF(1), 1), vbUnicode)), vbCrLf)
    
22.     Close #1
    
23.         ReDim crr(1 To UBound(brr) + 1, 1 To 7)
    
24.         For b = 0 To UBound(brr)
    
25.             brr(b) = Trim(brr(b))
    
26.             tmp = Split(Replace(brr(b), vbTab, "|"), "|")
    
27.             If UBound(tmp) < 5 Then tmp = Split(Replace(brr(b), vbTab, "|") & String(5 - UBound(tmp), "|"), "|")
    
28.             For t = 0 To UBound(tmp)
    
29.                 crr(b + 1, t + 1) = tmp(t)
    
30.             Next
    
31.         Next
    
32.         Cells(1, (i - 1) * 6 + 1).Resize(b, 6) = crr
    
33.     End If
    
34. Next
    
35. End Sub
    
36. Sub BubbleSort2(ByRef arr, x)
    
37.   Dim i&, j&, vSwap1, vSwap2
    
38.   For i = x To 2 Step -1
    
39.     For j = 1 To i - 1
    
40.       If arr(j, 2) > arr(j + 1, 2) Then
    
41.         vSwap1 = arr(j, 1)
    
42.         vSwap2 = arr(j, 2)
    
43.         arr(j, 1) = arr(j + 1, 1)
    
44.         arr(j, 2) = arr(j + 1, 2)
    
45.         arr(j + 1, 1) = vSwap1
    
46.         arr(j + 1, 2) = vSwap2
    
47.       End If
    
48.     Next
    
49.   Next
    
50. End Sub

复制代码

跳转到最佳答案楼层

爱疯

手动粘贴2个文档，看看效果？

2198596388

爱疯 发表于 2015-7-27 16:21
手动粘贴2个文档，看看效果？

文件夹(已手动粘贴了2个文档的内容).rar (412.4 KB, 下载次数: 2)

2015-7-27 16:51 上传

点击文件名下载附件 我手动粘贴了2个文档的内容，就是要这样粘贴的效果，要求用VBA代码完成，代码怎么写呢？

gufengaoyue

1. Sub 方法一()
   
2. 'On Error Resume Next
   
3. Dim fName, arr$(1 To 4 ^ 10, 1 To 2), b, brr, crr As Variant
   
4. fName = Dir(ThisWorkbook.Path & "")
   
5. Do Until fName = ""
   
6.     If UCase(Right(fName, 3)) = "TXT" Then
   
7.         a = a + 1:
   
8.         arr(a, 1) = fName
   
9.         arr(a, 2) = Val(Left(fName, 8))
   
10.     End If
    
11.     fName = Dir()
    
12. Loop
    
13. BubbleSort2 arr, a
    
14. Cells.Clear
    
15. For i = 1 To a
    
16.     Open ThisWorkbook.Path & "" & arr(i, 1) For Input As #1
    
17.         brr = Split(Trim(StrConv(InputB(LOF(1), 1), vbUnicode)), vbCrLf)
    
18.     Close #1
    
19.         ReDim crr(1 To UBound(brr) + 1, 1 To 7)
    
20.         For b = 0 To UBound(brr)
    
21.             brr(b) = Trim(brr(b))
    
22.             tmp = Split(Replace(brr(b), vbTab, "|"), "|")
    
23.             If UBound(tmp) < 5 Then tmp = Split(Replace(brr(b), vbTab, "|") & String(5 - UBound(tmp), "|"), "|")
    
24.             For t = 0 To UBound(tmp)
    
25.                 crr(b + 1, t + 1) = tmp(t)
    
26.             Next
    
27.         Next
    
28.         Cells(1, (i - 1) * 6 + 1).Resize(b, 6) = crr
    
29. Next
    
30. End Sub
    
31. Sub BubbleSort2(ByRef arr, x)
    
32.   Dim i&, j&, vSwap1, vSwap2
    
33.   For i = x To 2 Step -1
    
34.     For j = 1 To i - 1
    
35.       If arr(j, 2) > arr(j + 1, 2) Then
    
36.         vSwap1 = arr(j, 1)
    
37.         vSwap2 = arr(j, 2)
    
38.         arr(j, 1) = arr(j + 1, 1)
    
39.         arr(j, 2) = arr(j + 1, 2)
    
40.         arr(j + 1, 1) = vSwap1
    
41.         arr(j + 1, 2) = vSwap2
    
42.       End If
    
43.     Next
    
44.   Next
    
45. End Sub
    

复制代码

1. 
   
2. Sub 方法二()
   
3. On Error Resume Next
   
4. Dim fName, arr$(1 To 4 ^ 10, 1 To 2), tmpFolder$, b
   
5. fName = Dir(ThisWorkbook.Path & "")
   
6. tmpFolder$ = ThisWorkbook.Path & "\Xmp":  CreFold tmpFolder
   
7. Do Until fName = ""
   
8.     If UCase(Right(fName, 3)) = "TXT" Then
   
9.         a = a + 1:
   
10.         arr(a, 1) = Replace(fName, "-", "")
    
11.         arr(a, 2) = Val(Left(fName, 8))
    
12.         If Not b(tmpFolder & "" & arr(a, 1)) Then FileCopy ThisWorkbook.Path & "" & fName, tmpFolder & "" & arr(a, 1)
    
13.     End If
    
14.     fName = Dir()
    
15. Loop
    
16. Cells.ClearContents
    
17. BubbleSort2 arr, a
    
18. For i = 1 To a
    
19. brr = RstTxt(tmpFolder, arr(i, 1)).getrows()
    
20.     For b = 0 To UBound(brr, 2)
    
21.         tmp = Split(Replace(brr(0, b), vbTab, "|"), "|")
    
22.         If UBound(tmp) < 5 Then brr(0, b) = Split(Replace(brr(0, b), vbTab, "|") & String(5 - UBound(tmp), "|"), "|") Else brr(0, b) = tmp
    
23.     Next
    
24.     Cells(1, (i - 1) * 5 + 1).Resize(UBound(brr, 2), 5) = Application.Transpose(Application.Transpose(brr))
    
25. Next
    
26. Shell "cmd.exe /C rd /s /q " & tmpFolder, 0
    
27. End Sub
    
28. Function b(fPath As String)
    
29.         Dim fs, F
    
30.         Set fs = CreateObject("Scripting.FileSystemObject")
    
31.         If fs.fileexists(fPath) Then b = True Else b = False
    
32.         Set fs = Nothing: Set F = Nothing
    
33. End Function
    
34. Function CreFold(fPath)
    
35.         Dim fs, F
    
36.         Set fs = CreateObject("Scripting.FileSystemObject")
    
37.         fs.createfolder fPath & ""
    
38.         Set fs = Nothing: Set F = Nothing
    
39. End Function
    
40. Function RstTxt(Folder, Txt)
    
41. Dim Cnn, Rst
    
42. Set Cnn = CreateObject("adodb.connection")
    
43. Set Rst = CreateObject("adodb.recordset")
    
44. Cnn.Open "Provider=microsoft.ace.oledb.12.0;Extended Properties='text;IMEX=1;HDR=NO;FMT=Delimited(    )';Data Source=" & Folder
    
45. Rst.Open "select * from " & Txt & " WHERE f1 <> null", Cnn, 1, 3
    
46. Set RstTxt = Rst
    
47. End Function
    
48. Sub BubbleSort2(ByRef arr, x)
    
49.   Dim i&, j&, vSwap1, vSwap2
    
50.   For i = x To 2 Step -1
    
51.     For j = 1 To i - 1
    
52.       If arr(j, 2) > arr(j + 1, 2) Then
    
53.         vSwap1 = arr(j, 1)
    
54.         vSwap2 = arr(j, 2)
    
55.         arr(j, 1) = arr(j + 1, 1)
    
56.         arr(j, 2) = arr(j + 1, 2)
    
57.         arr(j + 1, 1) = vSwap1
    
58.         arr(j + 1, 2) = vSwap2
    
59.       End If
    
60.     Next
    
61.   Next
    
62. End Sub

复制代码

2198596388

gufengaoyue 发表于 2015-7-27 17:37

辛苦老师！先谢谢老师了！看起来有点复杂，老师能简单点吗？
我的效果要求是：把文件夹中的一部分文档，就是在代码中输入1个起始日期 20150320 和1个截止日期 20150403，就可以把20150320~20150403 这部分文档内容一个个的复制粘贴到 sheets("存档")工作表中就可以了。辛苦老师再帮忙看看，感谢老师！

gufengaoyue

2198596388 发表于 2015-7-27 18:28
辛苦老师！先谢谢老师了！看起来有点复杂，老师能简单点吗？
我的效果要求是：把文件夹中的一部分文档， ...

1. Sub 方法一()
   
2. On Error Resume Next
   
3. Dim fName, arr$(1 To 4 ^ 10, 1 To 2), b, brr, crr As Variant, x&, y&
   
4. x = InputBox("开始日期", , 20150318)
   
5. y = InputBox("结束日期", , 20150320)
   
6. If x = 0 Or y = 0 Or Err.Number <> 0 Then Exit Sub
   
7. fName = Dir(ThisWorkbook.Path & "")
   
8. Do Until fName = ""
   
9.     If UCase(Right(fName, 3)) = "TXT" Then
   
10.         a = a + 1:
    
11.         arr(a, 1) = fName
    
12.         arr(a, 2) = Val(Left(fName, 8))
    
13.     End If
    
14.     fName = Dir()
    
15. Loop
    
16. BubbleSort2 arr, a
    
17. Cells.Clear
    
18. For i = 1 To a
    
19.     If arr(i, 2) >= x And arr(i, 2) <= y Then
    
20.     Open ThisWorkbook.Path & "" & arr(i, 1) For Input As #1
    
21.         brr = Split(Trim(StrConv(InputB(LOF(1), 1), vbUnicode)), vbCrLf)
    
22.     Close #1
    
23.         ReDim crr(1 To UBound(brr) + 1, 1 To 7)
    
24.         For b = 0 To UBound(brr)
    
25.             brr(b) = Trim(brr(b))
    
26.             tmp = Split(Replace(brr(b), vbTab, "|"), "|")
    
27.             If UBound(tmp) < 5 Then tmp = Split(Replace(brr(b), vbTab, "|") & String(5 - UBound(tmp), "|"), "|")
    
28.             For t = 0 To UBound(tmp)
    
29.                 crr(b + 1, t + 1) = tmp(t)
    
30.             Next
    
31.         Next
    
32.         Cells(1, (i - 1) * 6 + 1).Resize(b, 6) = crr
    
33.     End If
    
34. Next
    
35. End Sub
    
36. Sub BubbleSort2(ByRef arr, x)
    
37.   Dim i&, j&, vSwap1, vSwap2
    
38.   For i = x To 2 Step -1
    
39.     For j = 1 To i - 1
    
40.       If arr(j, 2) > arr(j + 1, 2) Then
    
41.         vSwap1 = arr(j, 1)
    
42.         vSwap2 = arr(j, 2)
    
43.         arr(j, 1) = arr(j + 1, 1)
    
44.         arr(j, 2) = arr(j + 1, 2)
    
45.         arr(j + 1, 1) = vSwap1
    
46.         arr(j + 1, 2) = vSwap2
    
47.       End If
    
48.     Next
    
49.   Next
    
50. End Sub

复制代码