dati di copia dal lavoro chiuso basato su percorso definito dall'utente variabile
-
26-10-2019 - |
Domanda
Ho esaurito le mie capacità di ricerca alla ricerca di una soluzione a questo. Ecco una descrizione di quello che vorrei fare:
- L'utente apre con attivazione macro di file di Excel
- visualizzato il prompt immediati per l'utente per immettere o selezionare il percorso del file delle cartelle di lavoro desiderati. Essi dovranno scegliere due file, ei nomi di file potrebbero non essere coerenti
- Dopo aver inserito le posizioni dei file, il primo foglio dalla prima selezione del file verrà copiato il primo foglio della cartella di lavoro con attivazione macro, e il primo foglio di lavoro della seconda selezione del file verrà copiato il secondo foglio della macro cartella di lavoro -enabled.
ho incontrato alcuni riferimenti a ADO, ma io non sono molto familiare con quella ancora.
Edit: ho trovato un codice per importare i dati da un file chiuso. Ho bisogno di modificare il campo per restituire i risultati variabili.
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
Ora, ho bisogno di un pulsante di comando o userform che sarà immediatamente pronta all'utente di definire un percorso di file, e importare i dati da tale file.
Soluzione
Non mi dispiace se i file vengono aperti durante il processo. Ho appena non desidera che l'utente deve aprire i file singolarmente. Ho solo bisogno loro di essere in grado di selezionare o accedere al file desiderati
Ecco un codice di base. Questo codice chiede all'utente di selezionare due file e quindi importa il foglio relativo nella cartella di lavoro corrente. Ho dato due opzioni. Fate la vostra scelta:)
PROVATO E TESTATO
1 (importazione Sheets direttamente invece di copiare in sheet1 e 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 (Importa i fogli contenuti in sheet1 e 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
Altri suggerimenti
La funzione qui sotto legge i dati da un file Excel chiuso e restituisce il risultato in un array. Si perde la formattazione, le formule ecc Si potrebbe desiderare di chiamare la funzione isArrayEmpty (in basso) nel codice principale di prova che la funzione ha restituito qualcosa.
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
uso Esempio:
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