[已解决]用VBA怎么把CSV文件复制到EXCLE中

lui0326

求助啊，谁会啊
求助.zip (55.5 KB, 下载次数: 60)

2013-6-30 20:52 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

hwc2ycy

2013-6-30 21:17

1. Sub ReadCSV()
   
2.     Dim arr
   
3.     Dim strCSV As String
   
4.     On Error GoTo ErrorHandler
   
5. 
   
6. 
   
7.     strCSV = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, ".") - 1) & ".csv"
   
8.     If Len(Dir(strCSV)) = 0 Then
   
9.         MsgBox "当前工作簿目录下没有 " & strCSV, vbCritical + vbOKOnly
   
10.         Exit Sub
    
11.     End If
    
12. 
    
13.     With Application
    
14.         .ScreenUpdating = False
    
15.         .DisplayAlerts = False
    
16.         .EnableEvents = False
    
17.         .Calculation = xlCalculationManual
    
18.     End With
    
19. 
    
20.     Workbooks.Open Filename:=strCSV, ReadOnly:=True
    
21. 
    
22.     arr = ActiveSheet.UsedRange.Value
    
23.     ActiveWorkbook.Close False
    
24.    
    
25.     If IsArray(arr) Then
    
26.         With Worksheets("read")
    
27.             .Cells(Rows.Count, 1).End(xlUp).Offset(2).Resize(UBound(arr), UBound(arr, 2)).Value = arr
    
28.         End With
    
29.         MsgBox "复制完成"
    
30.     End If
    
31. 
    
32.     With Application
    
33.         .ScreenUpdating = True
    
34.         .DisplayAlerts = True
    
35.         .EnableEvents = True
    
36.         .Calculation = xlCalculationAutomatic
    
37.     End With
    
38. 
    
39.     Exit Sub
    
40. 
    
41. ErrorHandler:
    
42.     With Application
    
43.         .ScreenUpdating = True
    
44.         .DisplayAlerts = True
    
45.         .EnableEvents = True
    
46.         .Calculation = xlCalculationAutomatic
    
47.     End With
    
48. 
    
49.     MsgBox Err.Number & vbCrLf & _
    
50.            Err.Description
    
51. End Sub
    

复制代码

跳转到最佳答案楼层

hwc2ycy

是追加复制还是？

su45

把csv文件看作xls文件一样处理！

hwc2ycy

1. Sub ReadCSV()
   
2.     Dim arr
   
3.     Dim strCSV As String
   
4.     On Error GoTo ErrorHandler
   
5. 
   
6. 
   
7.     strCSV = Left(ThisWorkbook.FullName, InStrRev(ThisWorkbook.FullName, ".") - 1) & ".csv"
   
8.     If Len(Dir(strCSV)) = 0 Then
   
9.         MsgBox "当前工作簿目录下没有 " & strCSV, vbCritical + vbOKOnly
   
10.         Exit Sub
    
11.     End If
    
12. 
    
13.     With Application
    
14.         .ScreenUpdating = False
    
15.         .DisplayAlerts = False
    
16.         .EnableEvents = False
    
17.         .Calculation = xlCalculationManual
    
18.     End With
    
19. 
    
20.     Workbooks.Open Filename:=strCSV, ReadOnly:=True
    
21. 
    
22.     arr = ActiveSheet.UsedRange.Value
    
23.     ActiveWorkbook.Close False
    
24.    
    
25.     If IsArray(arr) Then
    
26.         With Worksheets("read")
    
27.             .Cells(Rows.Count, 1).End(xlUp).Offset(2).Resize(UBound(arr), UBound(arr, 2)).Value = arr
    
28.         End With
    
29.         MsgBox "复制完成"
    
30.     End If
    
31. 
    
32.     With Application
    
33.         .ScreenUpdating = True
    
34.         .DisplayAlerts = True
    
35.         .EnableEvents = True
    
36.         .Calculation = xlCalculationAutomatic
    
37.     End With
    
38. 
    
39.     Exit Sub
    
40. 
    
41. ErrorHandler:
    
42.     With Application
    
43.         .ScreenUpdating = True
    
44.         .DisplayAlerts = True
    
45.         .EnableEvents = True
    
46.         .Calculation = xlCalculationAutomatic
    
47.     End With
    
48. 
    
49.     MsgBox Err.Number & vbCrLf & _
    
50.            Err.Description
    
51. End Sub
    

复制代码

hwc2ycy

我的代码里读取数据后隔了一行再写入的，你根据实际情况来调整。
.Cells(Rows.Count, 1).End(xlUp).Offset(2)

lui0326

hwc2ycy 发表于 2013-6-30 21:18
我的代码里读取数据后隔了一行再写入的，你根据实际情况来调整。
.Cells(Rows.Count, 1).End(xlUp).Offset ...

是吧CSV文件拷贝到READ的工作表中，有一段语法错误
指点

lui0326

谢谢了，把后面删除就可以运行了
非常感谢

hwc2ycy

data.rar (58.11 KB, 下载次数: 140)

2013-7-2 23:22 上传

点击文件名下载附件

lui0326

hwc2ycy 发表于 2013-7-2 23:22

非常感谢，其实昨天的都可以了，把后面的删除就会重复复制，现在好了，就覆盖原来的位置。

wangliqin2014

我复制了版主的代码，总提示下标越界，怎么回事啊？