Question

怎样用VBA将多个工作簿指定相同区域复制到新的工作薄中指定区域？

我有很多个.CSV格式的文件（文件内格式完全相同，数值不同），需要从这些文件中提取某列200个数据（B20：B220）放到新的 数据提取excel 中。放置方法为：对应文件名下200个数据，为一列(B4：B204)，另一个文件名下的200个数据为向右移一列(C4：C204)。请大神帮写个VBA代码！！谢谢 ，能在第3行自动填写文件名最好！

Answer 1

其实你的这个要求并不难实现，如果设置得当的话，也不需要VBA。只用公式，名称就完全可以达到这个目的。

当然，我这个是在同一个工作簿中：

1、 定义B1:I11，即原数据表为 名称 “xuesheng”；

2、在目标表中姓名列下输入如图的公式，再下拉到所需要的单元格即可。

对于不在同一个工作簿中的，可以用以下方法来变相实现:

1、 在目标表所在的工作簿中新建一个工作表（以下简称“A表”），同时，打开原基础数据表（以下简称“B表”）；

2、 在A表中A1单元格输入“=”，然后选到B表，点击B表的A1单元格；也就是建立引用关系。

至于是用绝对引用，还是用相对引用，请自行根据应用实际情况决定；

3、此时就可以像之前在一个工作簿一样操作，设置，就能显示所需要的姓名列表了。

每次打开该工作簿时，会提示要更新链接，直接点确定就好了。嫌麻烦，可以在“信任中心”里把“更新链接”设置为启动时自动更新。

Answer 2

答：下面程序是按照你的要求从每个文件的B列取数，然后汇总到同一张表中。而且自动添加了文件名。

Sub ReadFromCSV()
    Dim vFiles As Variant
    Dim nIndex As Integer
    Dim Wkb As Workbook
    Dim DesRng As Range  

    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    vFiles = Application.GetOpenFilename(FileFilter:="CSV文件(*.csv),*.csv", _
    Title:="选择需读取的文件", MultiSelect:=True)
    If Not IsArray(vFiles) Then Exit Sub
    Set DesRng = ActiveSheet.Range("B3")
    For nIndex = 1 To UBound(vFiles)
        Set Wkb = Workbooks.Open(vFiles(nIndex))
        DesRng = Replace(Wkb.Name, ".csv", "")
        With Wkb
            .Sheets(1).Range("B20:B220").Copy
            DesRng.Offset(1, 0).PasteSpecial xlPasteValues
            .Close savechanges:=False
        End With
        Set Wkb = Nothing
        Set DesRng = DesRng.Offset(0, 1)
    Next nIndex
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "读取完成！", vbInformation, "提示"
End Sub

追问

初步功能实现了
我的想法是在EXCEL中做个按钮。点击按钮，会把excel当前目录下“固定文件夹”里的所有.CSV文件内容自动导入，不需要手动选取。
能不能再帮我改改。还有速度有点慢，能提下速不？

追答

现在把弹框选择文件改写为从固定目录中读取，代码中的“strPath”目录你再修改。

Sub ReadFromCSV()
    Dim Wkb As Workbook
    Dim DesRng As Range
    Dim strPath As String
    Dim FileName As String  

    strPath = "D:\CSV文件夹\"
    FileName = Dir(strPath & "*.csv")
    Set DesRng = ActiveSheet.Range("B3")
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    Do Until FileName = ""
        Set Wkb = Workbooks.Open(strPath & FileName)
            DesRng = Replace(Wkb.Name, ".csv", "")
            With Wkb
                .Sheets(1).Range("B20:B220").Copy
                DesRng.Offset(1, 0).PasteSpecial xlPasteValues
                .Close savechanges:=False
            End With
            Set Wkb = Nothing
            Set DesRng = DesRng.Offset(0, 1)
            FileName = Dir()
     Loop
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        MsgBox "读取完成！", vbInformation, "提示"
End Sub