Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 2041|回复: 9

[已解决]代码东拼西凑,但数据抓取复制仍是问题- -!

[复制链接]
发表于 2016-1-20 19:47 | 显示全部楼层 |阅读模式
最近在研究学习VBA,个人想将指定文件夹下里面的文件名与对应的列内容全部复制到一张表上,目前代码可以实现将文件名按列分布到一张表上,但是文件夹里面的指定内容无法完成复制粘贴工作,有高人指点下吗?

* 文件名汇总复制代码


Private Sub CommandButton1_Click()


  Dim fso As New FileSystemObject
  Dim r As Integer, path As String
  Set f = fso.GetFolder("D:\移动桌面\CSP数据")
  Worksheets("数据").Select
  r = Cells(1, Columns.Count).End(xlToLeft).Column                    'r = Cells(2, Columns.Count).End(xlToLeft).Column
  For Each wjm In f.Files
    If wjm.Name Like "*.csv" Then
      Cells(1, r) = Left(wjm.Name, Len(wjm.Name) - 4)                  'Left(wjm.Name, Len(wjm.Name) - 4)省略文件格式
      r = r + 1
    End If
  Next
  
  Set fso = Nothing
End Sub


最佳答案
2016-1-21 10:39
  1. Sub 导入文件()
  2.     Application.ScreenUpdating = False
  3.     Dim Filename, wb As Workbook, Sht As Worksheet, xRng As Range
  4.     Filename = Dir(ThisWorkbook.path & "\*.csv")
  5.     With ActiveSheet
  6.         .Cells.Clear
  7.         Do While Filename <> ""
  8.             fn = ThisWorkbook.path & "" & Filename
  9.             Set wb = Workbooks.Open(fn)
  10.             Set Sht = wb.Worksheets(1)
  11.             n = n + 1
  12.             .Cells(1, n) = Split(wb.Name, ".")(0)
  13.             Set xRng = Sht.UsedRange.Find("RANK", lookat:=xlWhole)
  14.             If Not xRng Is Nothing Then
  15.                 rmax = Sht.Cells(65536, xRng.Column).End(3).Row
  16.                 Sht.Range(xRng, Sht.Cells(rmax, xRng.Column)).Copy Cells(11, n)
  17.             End If
  18.             wb.Close False
  19.             Filename = Dir
  20.         Loop
  21.     End With
  22.     Application.ScreenUpdating = True
  23. End Sub
复制代码
目标效果.png

CSP数据.zip

234.29 KB, 下载次数: 21

发表于 2016-1-20 20:31 | 显示全部楼层
回复

使用道具 举报

发表于 2016-1-20 20:56 | 显示全部楼层
你的意思,是否将文件夹下带"*.csv后缀的表的所有内容,复制到“数据as.xls”工作簿的“数据”表中吗?如果是这样,那么就要用 dir语句依次循环查找带"*.csv表,然后用workbooks.open 或getobject语句将文件打开,再从中复制取数,这才是通用的作法。
回复

使用道具 举报

发表于 2016-1-20 21:04 | 显示全部楼层
你看懂他的csv文件与目标效果图的关系了吗?
回复

使用道具 举报

 楼主| 发表于 2016-1-21 08:27 | 显示全部楼层
lichuanboy44 发表于 2016-1-20 20:56
你的意思,是否将文件夹下带"*.csv后缀的表的所有内容,复制到“数据as.xls”工作簿的“数据”表中吗?如果 ...

您好,不是*.CSV工作簿中所有的内容,是C列33行往下所有的数据内容复制到“数据工作表内”,不清楚这样子解释,您听明白了没?
qq.png
回复

使用道具 举报

发表于 2016-1-21 10:39 | 显示全部楼层    本楼为最佳答案   
  1. Sub 导入文件()
  2.     Application.ScreenUpdating = False
  3.     Dim Filename, wb As Workbook, Sht As Worksheet, xRng As Range
  4.     Filename = Dir(ThisWorkbook.path & "\*.csv")
  5.     With ActiveSheet
  6.         .Cells.Clear
  7.         Do While Filename <> ""
  8.             fn = ThisWorkbook.path & "" & Filename
  9.             Set wb = Workbooks.Open(fn)
  10.             Set Sht = wb.Worksheets(1)
  11.             n = n + 1
  12.             .Cells(1, n) = Split(wb.Name, ".")(0)
  13.             Set xRng = Sht.UsedRange.Find("RANK", lookat:=xlWhole)
  14.             If Not xRng Is Nothing Then
  15.                 rmax = Sht.Cells(65536, xRng.Column).End(3).Row
  16.                 Sht.Range(xRng, Sht.Cells(rmax, xRng.Column)).Copy Cells(11, n)
  17.             End If
  18.             wb.Close False
  19.             Filename = Dir
  20.         Loop
  21.     End With
  22.     Application.ScreenUpdating = True
  23. End Sub
复制代码

CSP数据.rar

230.94 KB, 下载次数: 5

回复

使用道具 举报

发表于 2016-1-21 10:43 | 显示全部楼层
16句少写了一个".",应该为Sht.Range(xRng, Sht.Cells(rmax, xRng.Column)).Copy .Cells(11, n)
否则如果代码在模块中运行会出错的。
回复

使用道具 举报

 楼主| 发表于 2016-1-21 12:58 | 显示全部楼层
grf1973 发表于 2016-1-21 10:39

程序运行非常完美!!!满足设计要求,顺便问一下,请问你是VBA程序大师还是老师呀,为啥懂的这么多,程序编写调试的这么厉害呢?
回复

使用道具 举报

发表于 2016-1-21 13:17 | 显示全部楼层
无他,唯手熟尔。
回复

使用道具 举报

 楼主| 发表于 2016-1-21 19:35 | 显示全部楼层
grf1973 发表于 2016-1-21 13:17
无他,唯手熟尔。

真是高手呀,静下心来研究了下代码,这几行代码不是很理解,请您有空的时候解释下吗?

Set xRng = Sht.UsedRange.Find("RANK", lookat:=xlWhole)
            If Not xRng Is Nothing Then
                rmax = Sht.Cells(65536, xRng.Column).End(3).Row
                Sht.Range(xRng, Sht.Cells(rmax, xRng.Column)).Copy .Cells(11, n)  
            End If
            wb.Close False



回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-29 12:39 , Processed in 0.442564 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表