如何使用VBA将已关闭的工作簿中的数据（保持关闭）复制到主工作簿中 [英] How to copy data from closed workbooks(keeping them closed) into master workbook using VBA

问题描述

我需要帮助从少数封闭的工作簿中复制数据，而不打开它们，使用VBA将其复制到主工作簿中。
今天我使用函数Workbooks.open为了这样做，虽然我使用4-6个文件来复制数据，每个文件需要打开 - 显着减慢复制操作。

$

我需要帮助在使用高效的VBA代码复制数据而不打开每个文件。

这里是我的代码的一个例子： / p>

 设置x = Workbooks.Open（C：\Bel.xls）
现在，从x：
 x.Sheets（每日数字）。范围（A13：j102）。复制
'现在，粘贴到工作表
 y.Activate 
表格（Data  -  Daily）。范围（N2）。PasteSpecial 
关闭x：
 Application.CutCopyMode = False 
 x.Close 
 ）.Range（M4）=日期
  

请帮助
提前感谢， / p>

解决方案

尝试这个。它使用ADO工作，而不打开源文件：

  Sub TransferData（）
 Dim sourceFile As Variant 
 
 Application.ScreenUpdating = False 
 Application.Calculation = xlCalculationManual 
 
 sourceFile =C：\Bel.xls
 
 GetData sourceFile，Daily数字，A13：j102，表格（数据 - 每日）。范围（N2），False，False 
 
 Application.Calculation = xlCalculationAutomatic 
 Application.ScreenUpdating = True 
 
 End Sub 
 
 Public Sub GetData（sourceFile As Variant，SourceSheet As String，_ 
 SourceRange As String，TargetRange As Range，Header As Boolean，UseHeaderRow As Boolean ）
'2007年12月30日，在Excel 2000-2007中工作
'http://www.rondebruin.nl/ado.htm 
 
 Dim rsCon As Object 
 Dim rsData As Object 
 Dim szConnect As String 
 Dim szSQL As String 
 Dim lCount As Long 
 
'创建连接字符串。 
如果Header = False则
如果Val（Application.Version）< 12 Then 
 szConnect =Provider = Microsoft.Jet.OLEDB.4.0; & _ 
Data Source =& sourceFile& ; & _ 
扩展属性=Excel 8.0; HDR =否; 
 Else 
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; & _ 
Data Source =& sourceFile& ; & _ 
扩展属性=Excel 12.0; HDR =否; 
 End If 
 Else 
如果Val（Application.Version）< 12 Then 
 szConnect =Provider = Microsoft.Jet.OLEDB.4.0; & _ 
Data Source =& sourceFile& ; & _ 
Extended Properties =Excel 8.0; HDR = Yes; 
 Else 
 szConnect =Provider = Microsoft.ACE.OLEDB.12.0; & _ 
Data Source =& sourceFile& ; & _ 
扩展属性=Excel 12.0; HDR =是; 
如果
结束如果
 
结束如果SourceSheet =那么
'工作簿级别名称
 szSQL =SELECT * FROM& SourceRange $& ; 
 Else 
'工作表级别名称或范围
 szSQL =SELECT * FROM [& SourceSheet $& $& SourceRange $& ]; 
结束如果
 
错误GoTo SomethingWrong 
 
设置rsCon = CreateObject（ADODB.Connection）
设置rsData = CreateObject（ADODB.Recordset ）
 
 rsCon.Open szConnect 
 rsData.Open szSQL，rsCon，0，1，1 
 
'检查以确保我们接收到数据并复制数据
如果不是rsData.EOF则
 
如果Header = False则
 TargetRange.Cells（1,1）.CopyFromRecordset rsData 
 Else 
'如果最后一个参数为True，则每个列中的标题单元格
如果UseHeaderRow然后
对于lCount = 0到rsData.Fields.Count  -  1 
 TargetRange.Cells（1，1 + lCount）.Value = _ 
 rsData.Fields（lCount）.Name 
 Next lCount 
 TargetRange.Cells（2，1）.CopyFromRecordset rsData 
 Else 
 TargetRange.Cells（1， 1）.CopyFromRecordset rsData 
结束如果
结束如果
 
否则
 MsgBox没有记录返回：& sourceFile，vbCritical 
 End If 
 
'清理我们的Recordset对象。 
 rsData.Close 
设置rsData = Nothing 
 rsCon.Close 
设置rsCon =无
退出子
 
 SomethingWrong：
 MsgBox文件名，工作表名称或范围无效：& sourceFile，_ 
 vbExclamation，错误
错误转到0 
 
结束子
  

i need help to copy data from few closed workbooks, without opening them, into a master workbook using VBA. today i use the function Workbooks.open in order to do so, though i use 4-6 files to copy data from, and each file that needs to open - slows down dramatically the copy operation.

i need help in using efficient VBA code for copying data without opening each file.

here is an example of my code:

Set x = Workbooks.Open("C:\Bel.xls")
    'Now, copoy what you want from x:
    x.Sheets("Daily Figures").Range("A13:j102").Copy
    'Now, paste to y worksheet
    y.Activate
    Sheets("Data - Daily").Range("N2").PasteSpecial
    'Close x:
    Application.CutCopyMode = False
    x.Close
    Sheets("sheet1").Range("M4") = Date

please help thanks in advance,

解决方案

Try this. It works using ADO without opening a source file:

Sub TransferData()
Dim sourceFile As Variant

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

sourceFile = "C:\Bel.xls"

GetData sourceFile, "Daily Figures", "A13:j102", Sheets("Data - Daily").Range("N2"), False, False

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Public Sub GetData(sourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
' http://www.rondebruin.nl/ado.htm

Dim rsCon As Object
Dim rsData As Object
Dim szConnect As String
Dim szSQL As String
Dim lCount As Long

' Create the connection string.
If Header = False Then
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=No"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                    "Extended Properties=""Excel 12.0;HDR=No"";"
    End If
Else
    If Val(Application.Version) < 12 Then
        szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                    "Extended Properties=""Excel 8.0;HDR=Yes"";"
    Else
        szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                    "Data Source=" & sourceFile & ";" & _
                    "Extended Properties=""Excel 12.0;HDR=Yes"";"
    End If
End If

If SourceSheet = "" Then
    ' workbook level name
    szSQL = "SELECT * FROM " & SourceRange$ & ";"
Else
    ' worksheet level name or range
    szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
End If

On Error GoTo SomethingWrong

Set rsCon = CreateObject("ADODB.Connection")
Set rsData = CreateObject("ADODB.Recordset")

rsCon.Open szConnect
rsData.Open szSQL, rsCon, 0, 1, 1

' Check to make sure we received data and copy the data
If Not rsData.EOF Then

    If Header = False Then
        TargetRange.Cells(1, 1).CopyFromRecordset rsData
    Else
        'Add the header cell in each column if the last argument is True
        If UseHeaderRow Then
            For lCount = 0 To rsData.Fields.Count - 1
                TargetRange.Cells(1, 1 + lCount).Value = _
                rsData.Fields(lCount).Name
            Next lCount
            TargetRange.Cells(2, 1).CopyFromRecordset rsData
        Else
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        End If
    End If

Else
    MsgBox "No records returned from : " & sourceFile, vbCritical
End If

' Clean up our Recordset object.
rsData.Close
Set rsData = Nothing
rsCon.Close
Set rsCon = Nothing
Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & sourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0

End Sub

这篇关于如何使用VBA将已关闭的工作簿中的数据（保持关闭）复制到主工作簿中的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！