Question

我希望完成的工作是从封闭的工作簿（列D，H，Q和R列）中复制选择的数据范围，然后将其粘贴到活动的工作簿中（具有以下代码的工作簿）。下面的代码完成了该操作，但是对于不应该显示的值，它显示为“ NULL”。例如，我要复制全部非数字的货币（USD，CAD，GBP），其中一部分显示为“ NULL”。另一个目标是使复制的数据范围像关闭的工作簿一样显示（按关闭的工作簿的顺序），例如，列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

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

1 个答案: