Скопируйте более одного диапазона данных из закрытой книги - PullRequest
Новая
       17

Скопируйте более одного диапазона данных из закрытой книги

0 голосов
/ 09 мая 2019

То, что я надеюсь сделать, это скопировать выбранные диапазоны данных из закрытой рабочей книги (столбцы 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

Дайте мне знать, если вам нужно, чтобы я что-то объяснил более подробно.

1 Ответ

1 голос
/ 10 мая 2019

Как-то так - пропускаем всю вещь 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
...