从已关闭的工作簿中复制多个范围的数据

Question

我希望完成的是从关闭的工作簿（D、H、Q 和 R 列）复制 select 范围的数据并将它们粘贴到活动工作簿（代码如下的工作簿）中.下面的代码完成了它，但它显示了 "NULL" 它不应该显示的值。例如，我复制的货币（美元、加元、英镑）都是非数字的，其中一部分显示"NULL"。另一个 objective 是复制数据范围以像关闭的工作簿一样显示（按照关闭的工作簿的顺序）例如列 A 显示一个实体，右侧的所有列显示该实体的数据.

Sub GetData_Example4()
Dim SaveDriveDir As String, MyPath As String
Dim FName As Variant

SaveDriveDir = CurDir
MyPath = Application.DefaultFilePath    'or use "C:\Data"
ChDrive MyPath
ChDir MyPath
FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*")

If FName = False Then
    'do nothing
Else
    GetData FName, "Sheet1", "D1:D10000", Sheets("Sheet1").Range("A1"), 
False, False
    GetData FName, "Sheet1", "H1:H10000", Sheets("Sheet1").Range("B1"), 
False, False
    GetData FName, "Sheet1", "Q1:Q10000", Sheets("Sheet1").Range("C1"), 
False, False
    GetData FName, "Sheet1", "R1:R10000", Sheets("Sheet1").Range("D1"), 
False, False
End If

ChDrive SaveDriveDir
ChDir SaveDriveDir
End Sub

下面是 "GetData"

的代码

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As 
Boolean, UseHeaderRow As Boolean)

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

如果您需要我更详细地解释任何内容，请告诉我。

Answer 1

类似这样的事情 - 跳过整个 ADO 事情：

Sub GetData_Example4()

    Dim SaveDriveDir As String, MyPath As String
    Dim FName As Variant, wb As Workbook, shtDest As Worksheet

    SaveDriveDir = CurDir
    MyPath = Application.DefaultFilePath    'or use "C:\Data"
    ChDrive MyPath
    ChDir MyPath
    FName = Application.GetOpenFilename(filefilter:="Excel Files, *.xl*")

    If FName = False Then
        'do nothing
    Else
        Application.ScreenUpdating = False
        Set shtDest = ThisWorkbook.Sheets("Sheet1")
        With Workbooks.Open(FName, ReadOnly:=True)
            .Sheets("Sheet1").Range("D1:D10000").Copy shtDest.Range("A1")
            .Sheets("Sheet1").Range("H1:H10000").Copy shtDest.Range("B1")
            .Sheets("Sheet1").Range("Q1:Q10000").Copy shtDest.Range("C1")
            .Sheets("Sheet1").Range("R1:R10000").Copy shtDest.Range("D1")
            .Close False '<< fixed
        End With
        Application.ScreenUpdating = True
    End If

    ChDrive SaveDriveDir
    ChDir SaveDriveDir
End Sub

从已关闭的工作簿中复制多个范围的数据

Copy more than one range of data from a closed workbook

excel

vba

external