변수 사용자 정의 경로를 기반으로 닫힌 통합 문서에서 데이터 복사

Question

나는이 문제를 해결하기 위해 내 검색 기능을 다 써 버렸습니다.

• 사용자가 매크로 사용 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 

지금, 나는 즉시 파일 경로를 정의하는 메시지가 사용자에게 표시하고 해당 파일에서 데이터를 가져옵니다 명령 단추 또는 사용자 정의 폼이 필요합니다.

Answer 1

파일이 과정에서 열 경우 난 상관 없어. 난 그냥 사용자가 파일을 개별적으로 열 필요가 없었어요. 나는 단지 그들이 원하는 파일

여기에 기본 코드가

로 선택하거나 탐색 할 수 있어야합니다. 이 코드는 사용자에게 두 개의 파일을 선택하도록 요청한 다음 관련 시트를 현재 통합 문서로 가져옵니다. 나는 두 가지 선택권을 주었다. 선택지 : 가지고

는 시도

옵션 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 (가져 오기 스프레드 시트 내용을 테스트 완료 시트 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).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 

Answer 2

아래 함수는 닫힌 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