You are here:---Rispondi a: [RISOLTO] Importare alcune colonne da foglio esterno
Rispondi a: [RISOLTO] Importare alcune colonne da foglio esterno2019-07-18T22:15:33+02:00

Home Forum Domande su Excel VBA e MACRO [RISOLTO] Importare alcune colonne da foglio esterno Rispondi a: [RISOLTO] Importare alcune colonne da foglio esterno

sidsid
Moderatore
    Post totali: 718

    Ti passo la macro + una udf che estrae il nome del file da aprire.
    Va messo tutto in un modulo standard
    Questa la udf

    Public Function NOME_FILE_CON_ESTENSIONE(ByVal sDir As String) As String
    NOME_FILE_CON_ESTENSIONE = Mid(sDir, InStrRev(sDir, "\", , vbTextCompare) + 1, Len(sDir))
    End Function

    Questa la macro da abbinare ad un pulsante

    Sub IMPORTA()
    Dim wbMaster As Workbook, wbSlave As Workbook
    Dim wsMaster As Worksheet, wsSlave As Worksheet
    Dim j As Long, nIncr As Long, nRiga As Long
    Dim vMatrix() As Variant, vTabella As Variant
    Dim fd As FileDialog
    Dim sPercorso As String, sNomeFile As String
    Dim rng As Range
    
    Set fd = Application.FileDialog(msoFileDialogFilePicker)
    Set wbMaster = ThisWorkbook
    Set wsMaster = wbMaster.Sheets("Riesume")
    
    Application.ScreenUpdating = False
    On Error GoTo GEST_ERR
    
    'directory dove si aprirà l'esplora risorse
    fd.InitialFileName = "I:\Produzione\2019\"
    
    If Not fd.Show Then
         Err.Raise vbObjectError + 513, Description:="Operazione annullata"
    End If
    sNomeFile = NOME_FILE_CON_ESTENSIONE(fd.SelectedItems(1))
    
    '***********************************************************
    'GESTIONE APERTURA SLAVE
    On Error Resume Next
    If IsError(Application.Workbooks(sNomeFile)) Then
        Set wbSlave = Application.Workbooks.Open(sNomeFile)
    Else
        Set wbSlave = Application.Workbooks(sNomeFile)
    End If
    On Error GoTo 0
    '***********************************************************
    On Error GoTo GEST_ERR
    
    Set wsSlave = wbSlave.Sheets(1) ' primo foglio di slave
    Set rng = wsSlave.Range("B5:Q" & wsSlave.UsedRange.Rows.Count)
    vTabella = rng
    wbSlave.Close False 'ho i dati di slave quindi lo chiudo
    
    For j = LBound(vTabella) To UBound(vTabella)
        If vTabella(j, 1) <> vbNullString Then
            With Application
                'verifico se il dato è già presente nel master
                If IsError(.Match(vTabella(j, 1), wsMaster.Columns(1), 0)) Then
                    nIncr = nIncr + 1
                    ReDim Preserve vMatrix(1 To 6, 1 To nIncr)
                    vMatrix(1, nIncr) = vTabella(j, 1) 'dato1
                    vMatrix(2, nIncr) = vTabella(j, 2) 'dato2
                    vMatrix(3, nIncr) = vTabella(j, 4) 'dato3
                    vMatrix(4, nIncr) = vTabella(j, 5) 'dato4
                    vMatrix(5, nIncr) = vTabella(j, 16) 'dato5
                    vMatrix(6, nIncr) = sNomeFile 'mese importato
                End If
            End With
        End If
    Next j
    ReDim Preserve vMatrix(1 To 6, 1 To nIncr + 1)
    If nIncr = 0 Then
         Err.Raise vbObjectError + 513, Description:="Nessun valore da importare per il file ''" & sNomeFile & "''"
    End If
    
    vMatrix = Application.Transpose(vMatrix) 'traspongo la matrice creata
    
    With wsMaster
        nRiga = .Range("A" & Rows.Count).End(xlUp).Row + 1
        .Range("A" & nRiga & ":F" & nRiga + UBound(vMatrix) - 1) = vMatrix 'scarico la matrice nel foglio
        .Range("A:F").Columns.AutoFit 'adatto le colonne al testo
    End With
    Application.ScreenUpdating = True
    MsgBox "Importati " & nIncr & " elementi dal file ''" & sNomeFile & "''", vbInformation, "IMPORTAZIONE DATI"
    GEST_ERR:
    
    If Err.Number <> 0 Then
        MsgBox Err.Description, vbExclamation, "ATTENZIONE"
    End If
    
    Set wbMaster = Nothing
    Set wbSlave = Nothing
    Set wsMaster = Nothing
    Set wsSlave = Nothing
    Set rng = Nothing
    Set fd = Nothing
    End Sub

    Fa sapere, ciao.

    • Questa risposta è stata modificata 1 mese fa da sid sid.

    Utilizzando il sito, accetti l'utilizzo dei cookie da parte nostra. maggiori informazioni

    Questo sito utilizza i cookie per fornire la migliore esperienza di navigazione possibile. Continuando a utilizzare questo sito senza modificare le impostazioni dei cookie o cliccando su "Accetta" permetti il loro utilizzo.

    Chiudi