Excel vba Utilizzo di FileDialog(msoFileDialogFilePicker) e CreateObject(Scripting.FileSystemObject)

Question

Buon Giorno

Sto cercando di utilizzare lo strumento  FileDialog  per selezionare un File (Chiuso ) da cui prelevare dei dati presenti  in un Foglio  (Foglio sorgente ) e poi copiarli nel Foglio di Destinazione .

il codice che utilizzo attualmente , non permette la selezione del singolo file (nella cartella deve essere presente solo un file ...) quindi volevo rimediare 

andando a selezionare nella finestra di dialogo il file di interesse  .

Il codice che utilizzo e' il seguente :

Private Sub cbImporta_Click()

    Dim oFolder As Object

    Dim oFiles As Object

    Dim oFile As Object

    Dim srcWB As Workbook, destWB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range

    Dim destRng1 As Range

    Dim sNomeFoglioSorgente As String

    Dim sIntervalloDaCopiare As String

    Dim sIntervalloDaCopiare1 As String

    Dim Rng As Range

    Dim Rng1 As Range

    Dim sPercorso As String

    Dim iCtr As Long

    Dim sMsg As String, sTitle As String, iButtons As Long

    Dim LRow As Long

    Dim CalcMode As Long

    Dim sCol As Long

    Dim i As Long

    Const sNomeFoglioDestinazione As String = _

                                            "Squadre"                    '<<=== Modifica

    Const iRigaIntestazioneDestinazione As Long = 1  '<<=== Modifica

    sNomeFoglioSorgente = Application.InputBox( _

                          Prompt:="Digita il nome del foglio in cui " _

                                  & "si trovano i dati da copiare", _

                          Title:="NOME FOGLIO", _

                          Type:=2)

    If sNomeFoglioSorgente = "False" _

       Or sNomeFoglioSorgente = vbNullString Then

        Call MsgBox( _

             Prompt:="Non hai Inserito il Nome del  foglio!!", _

             Buttons:=vbCritical, _

             Title:="CODICE TERMINATO!")

        Exit Sub

    End If

    Set Rng = Application.InputBox( _

              Prompt:="Digita intervallo Colonne da " _

                      & "copiare (Es:. A2:C150 !", _

              Title:="INTERVALLO DA COPIARE", _

              Type:=8)

    If Rng Is Nothing Then

        Call MsgBox( _

             Prompt:="Non hai Inserito l'intervallo da copiare", _

             Buttons:=vbCritical, _

             Title:="CODICE TERMINATO!")

        Exit Sub

    End If

    sIntervalloDaCopiare = Rng.Address(0, 0)

    sPercorso = GetDirectory

    If sPercorso = vbNullString Then

        sMsg = "Non hai scelto una directory ! "

        sTitle = "CODICE TERMINATO !"

        iButtons = vbCritical

        GoTo XIT

    End If

    Set oFolder = oFSO.GetFolder(sPercorso)

    Set oFiles = oFolder.Files

    Set destWB = ThisWorkbook

    Set destSH = destWB.Sheets(sNomeFoglioDestinazione)

    With destSH

   Set destRng = destSH.Range(Me.tbPippo.Text)

    End With

''    On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    For Each oFile In oFiles

        Set srcWB = Workbooks.Open(oFile.Path)

        iCtr = iCtr + 1

        With srcWB

            Set srcSH = srcWB.Sheets(sNomeFoglioSorgente)

            Set srcRng = srcSH.Range(sIntervalloDaCopiare)

            srcRng.Copy Destination:=destRng

            Set destRng = destRng.Offset(srcRng.Rows.Count)

            srcWB.Close SaveChanges:=False

        End With

    Next oFile

    If CBool(iCtr) Then

        sMsg = "Dati da " & iCtr _

               & " file trovati nella directory " _

               & vbNewLine _

               & sPercorso _

               & vbNewLine _

               & " sono stato copiati nel foglio "

        sTitle = "REPORT"

        iButtons = vbInformation

    Else

        sMsg = "Nessun file è stato trovato nella directory " _

               & sPercorso & " !"

        sTitle = "FILE NON TROVATI !"

        iButtons = vbCritical

    End If

XIT:

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=iButtons, _

         Title:=sTitle)

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

    Set oFile = Nothing

    Set oFiles = Nothing

    Set oFolder = Nothing

    Set oFSO = Nothing

End Sub

'--------->>

Public Function GetDirectory() As String

Dim strPath As String

    Dim fd As FileDialog

    Dim objfd As Variant

    Dim sPercorso As String

    Dim oFolder As Folder

    Dim oFiles As File

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    With fd

            .InitialFileName = "C:"

            .Title = "Sfoglia cartelle"

            .ButtonName = "Ok"

            .AllowMultiSelect = False

            .InitialView = msoFileDialogViewDetails

            .Show

            For Each objfd In .SelectedItems

                strPath = objfd

            Next objfd

    End With

    If strPath = "" Then GoTo Uscita

    Set oFSO = New FileSystemObject

    Set oFolder = oFSO.GetFolder(strPath)

    For Each oFiles In oFolder.Files

            sPercorso = oFiles.Name

    Next

Uscita:

    Set oFSO = Nothing

    Set oFolder = Nothing

    Set fd = Nothing

    GetDirectory = sPercorso

    On Error GoTo XIT

    Application.ScreenUpdating = False

XIT:

        Application.ScreenUpdating = True

End Function

'--------->>

Public Function LastRow(sh As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = sh.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

Il codice e' stato realizzato  da Norman David Jones   (io mi sono limitato a copiarlo e ....massacrarlo  ....sigh )

La Parte evidenziata in grassetto e conseguenza dei miei  grossolani tentativi ...

Funziona fino alla selezione del file  nella finestra di dialogo  ...... poi errori a non finire

Cosa Manca   ????? 

                                 Grazie     Claudio P

Answer 1

            .Add "File Excel", "*.xls*"        " ...quindi se il file e' xlsm  dovro' aggiungere "*.xls*,*xlsm*"

Non ce n'è bisogno perché già cos' vengono visualizzati i file xlsm

ciao

Answer 2

Buon Giorno

Ho risolto  (Eureka !!!)

Ho aggiunto nella UserForm una  TextBox  (tbDirectory ) e gli ho assegnato l'indirizzo del File 

GetFileFullName = .SelectedItems(1)        

 ImportaDati.tbDirectory = GetFileFullName

a questo punto nella sezione del cbImporta 

Private Sub cbImporta_Click()

Set srcWB = Workbooks.Open(Me.tbDirectory)

Tahda !!!  ....... Funziona ... tutto il resto del codice e' rimasto ....

Devo comunque ancora imparare la sintassi per assegnare un percorso ad un oggetto  !!!!

          Grazie di nuovo per il suggerimento   Claudio P

Answer 3

buon giorno

E' vero la finestra di dialogo finalmente mi presenta tutti i file presenti nella cartella selezionata .

...... adesso sto' lavorando per  passare il dato   GetFileFullName = .SelectedItems(1)  al WorkBook.Open per poter finalmente assegnare il percorso 

al  srcWB  ( il file in cui cercare ) e di conseguenza  al Foglio in cui sono presenti i dati da copiare (srcSH )

Non mi e' semplice ....pero' ci provo     GRAZIE   

                            Claudio P

Answer 4

Buon Giorno

AAAAAAAAAAAAGGGGHHHH  !!!!

per questo molti errori  erano del tipo   " Necessario Oggetto "

Grazie  adesso provo a vedere cosa riesco a combinare      Grazie

.Title = "Seleziona File Excel"

         .ButtonName = "Ok"

         .AllowMultiSelect = False

         With .Filters

            .Clear

            .Add "File Excel", "*.xls*"        " ...quindi se il file e' xlsm  dovro' aggiungere "*.xls*,*xlsm*"

         End With

         If .Show = -1 Then

            GetFileFullName = .SelectedItems(1)

                                   Claudio  P

Answer 5

Più di "cosa manca" e "cosa non dovrebbe esserci? :)

Se vuoi, per ottenere il c.d. "FullName" del file da selezionare (e quindi aprire con il comando WorkBook.Open), potresti provare qualcosa del genere (che è un po' la rivisitazione della funzione GetDirectory ma per restituire la stringa del percorso completo con il nome del file selezionato):

Function GetFileFullName() As String

   With Application

      With .FileDialog(msoFileDialogFilePicker)

         .Title = "Seleziona File Excel"

         .ButtonName = "Ok"

         .AllowMultiSelect = False

         With .Filters

            .Clear

            .Add "File Excel", "*.xls*"

         End With

         If .Show = -1 Then

            GetFileFullName = .SelectedItems(1)

         End If

      End With

   End With

End Function

Nota che il filtro della finestra di dialogo è impostato per i file Excel.

Se viene selezionato un file viene restituita una stringa di testo con il percorso del file e il nome del file compresivo di estensione.

Es. C:\Users\casanamner\Documents\01-DOCUMENTI CLIENTI\ELENCO CLIENTI DICHIARAZIONI.xls