Копировать данные из закрытой рабочей книги на основе переменной, определенной пользователем

Я исчерпал свои возможности поиска в поисках решения этой проблемы. Вот схема того, что я хотел бы сделать:

  • Пользователь открывает файл Excel с поддержкой макросов
  • Немедленная подсказка отображает для пользователя, чтобы ввести или выбрать путь к файлу желаемых книг. Им нужно будет выбрать два файла, а имена файлов могут не совпадать
  • После ввода местоположений файлов первая рабочая таблица из первого выбора файлов будет скопирована на первый рабочий лист книги с поддержкой макросов, а первая рабочая таблица второго выбора файлов будет скопирована на второй рабочий лист книги с макросами.,

Я встречал некоторые ссылки на ADO, но я действительно еще не знаком с этим.

Изменить: я нашел код для импорта данных из закрытого файла. Мне нужно настроить диапазон, чтобы вернуть переменные результаты.

    Private Function GetValue(path, file, sheet, ref)

    path = "C:\Users\crathbun\Desktop"
    file = "test.xlsx"
    sheet = "Sheet1"
    ref = "A1:R30"

     '   Retrieves a value from a closed workbook
    Dim arg As String

     '   Make sure the file exists
    If Right(path, 1) <> "\" Then path = path & "\"
    If Dir(path & file) = "" Then
        GetValue = "File Not Found"
        Exit Function
    End If

     '   Create the argument
    arg = "'" & path & "[" & file & "]" & sheet & "'!" & _
    Range(ref).Range("A1").Address(, , xlR1C1)

     '   Execute an XLM macro
    GetValue = ExecuteExcel4Macro(arg)
End Function

Sub TestGetValue()

    path = "C:\Users\crathbun\Desktop"
    file = "test"
    sheet = "Sheet1"

    Application.ScreenUpdating = False
    For r = 1 To 30
        For C = 1 To 18
            a = Cells(r, C).Address
            Cells(r, C) = GetValue(path, file, sheet, a)
        Next C
    Next r

    Application.ScreenUpdating = True
End Sub

Теперь мне нужна командная кнопка или пользовательская форма, которая немедленно предложит пользователю определить путь к файлу и импортировать данные из этого файла.

Источник

2 ответа

Решение

Я не против, если файлы открываются во время процесса. Я просто не хотел, чтобы пользователь открывал файлы по отдельности. Мне просто нужно, чтобы они были в состоянии выбрать или перейти к нужным файлам

Вот основной код. Этот код просит пользователя выбрать два файла, а затем импортирует соответствующий лист в текущую рабочую книгу. Я дал два варианта. Сделайте ваш выбор:)

ПРОВЕРЕНО И ИСПЫТАНО

ВАРИАНТ 1 (импортировать листы напрямую вместо копирования в листы 1 и 2)

Option Explicit

Sub Sample()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim Ret1, Ret2

    Set wb1 = ActiveWorkbook

    '~~> Get the first File
    Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select first file")
    If Ret1 = False Then Exit Sub

    '~~> Get the 2nd File
    Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select Second file")
    If Ret2 = False Then Exit Sub

    Set wb2 = Workbooks.Open(Ret1)
    wb2.Sheets(1).Copy Before:=wb1.Sheets(1)
    ActiveSheet.Name = "Blah Blah 1"
    wb2.Close SaveChanges:=False

    Set wb2 = Workbooks.Open(Ret2)
    wb2.Sheets(1).Copy After:=wb1.Sheets(1)
    ActiveSheet.Name = "Blah Blah 2"
    wb2.Close SaveChanges:=False

    Set wb2 = Nothing
    Set wb1 = Nothing
End Sub

ВАРИАНТ 2 (импортировать содержимое листов в sheet1 и 2)

Option Explicit

Sub Sample()
    Dim wb1 As Workbook, wb2 As Workbook
    Dim Ret1, Ret2

    Set wb1 = ActiveWorkbook

    '~~> Get the first File
    Ret1 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select first file")
    If Ret1 = False Then Exit Sub

    '~~> Get the 2nd File
    Ret2 = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", _
    , "Please select Second file")
    If Ret2 = False Then Exit Sub

    Set wb2 = Workbooks.Open(Ret1)
    wb2.Sheets(1).Cells.Copy wb1.Sheets(1).Cells
    wb2.Close SaveChanges:=False

    Set wb2 = Workbooks.Open(Ret2)
    wb2.Sheets(1).Cells.Copy wb1.Sheets(2).Cells
    wb2.Close SaveChanges:=False

    Set wb2 = Nothing
    Set wb1 = Nothing
End Sub
Источник

Функция ниже считывает данные из закрытого файла Excel и возвращает результат в массиве. Он теряет форматирование, формулы и т. Д. Возможно, вы захотите вызвать функцию isArrayEmpty (внизу) в своем основном коде, чтобы проверить, что функция вернула что-то.

Public Function getDataFromClosedExcelFile(parExcelFileName As String, parSheetName As String) As Variant
'see http://www.ozgrid.com/forum/showthread.php?t=19559
'returns an array (1 to nRows, 1 to nCols) which should be tested with isArrayEmpty in the calling function

  Dim locConnection As New ADODB.Connection
  Dim locRst As New ADODB.Recordset
  Dim locConnectionString As String
  Dim locQuery As String
  Dim locCols As Variant
  Dim locResult As Variant
  Dim i As Long
  Dim j As Long

  On Error GoTo error_handler

  locConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" _
  & "Data Source=" & parExcelFileName & ";" _
  & "Extended Properties=""Excel 8.0;HDR=YES"";"

  locQuery = "SELECT * FROM [" & parSheetName & "$]"

  locConnection.Open ConnectionString:=locConnectionString
  locRst.Open Source:=locQuery, ActiveConnection:=locConnection
  If locRst.EOF Then 'Empty sheet or only one row
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''         FIX: an empty sheet returns "F1"
    ''''''         http://support.microsoft.com/kb/318373
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" Then Exit Function 'Empty sheet
    ReDim locResult(1 To 1, 1 To locRst.Fields.Count) As Variant
    For i = 1 To locRst.Fields.Count
      locResult(1, i) = locRst.Fields(i - 1).Name
    Next i
  Else
    locCols = locRst.GetRows
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    ''''''         FIX: an empty sheet returns "F1"
    ''''''         http://support.microsoft.com/kb/318373
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If locRst.Fields.Count = 1 And locRst.Fields(0).Name = "F1" And UBound(locCols, 2) = 0 And locCols(0, 0) = "" Then Exit Function 'Empty sheet

    ReDim locResult(1 To UBound(locCols, 2) + 2, 1 To UBound(locCols, 1) + 1) As Variant

    If locRst.Fields.Count <> UBound(locCols, 1) + 1 Then Exit Function 'Not supposed to happen

    For j = 1 To UBound(locResult, 2)
      locResult(1, j) = locRst.Fields(j - 1).Name
    Next j
    For i = 2 To UBound(locResult, 1)
      For j = 1 To UBound(locResult, 2)
        locResult(i, j) = locCols(j - 1, i - 2)
      Next j
    Next i
  End If

  locRst.Close
  locConnection.Close
  Set locRst = Nothing
  Set locConnection = Nothing

  getDataFromClosedExcelFile = locResult

  Exit Function
error_handler:
  'Wrong file name, sheet name, or other errors...
  'Errors (#N/A, etc) on the sheet should be replaced by Null but should not raise an error
  If locRst.State = ADODB.adStateOpen Then locRst.Close
  If locConnection.State = ADODB.adStateOpen Then locConnection.Close
  Set locRst = Nothing
  Set locConnection = Nothing

End Function

Public Function isArrayEmpty(parArray As Variant) As Boolean
'Returns false if not an array or dynamic array that has not been initialised (ReDim) or has been erased (Erase)

  If IsArray(parArray) = False Then isArrayEmpty = True
  On Error Resume Next
  If UBound(parArray) < LBound(parArray) Then isArrayEmpty = True: Exit Function Else: isArrayEmpty = False

End Function

Образец использования:

Sub test()

  Dim data As Variant

  data = getDataFromClosedExcelFile("myFile.xls", "Sheet1")
  If Not isArrayEmpty(data) Then
    'Copies content on active sheet
    ActiveSheet.Cells(1,1).Resize(UBound(data,1), UBound(data,2)) = data
  End If

End Sub
Источник
Другие вопросы по тегам