Copia e incolla dati da un file excel ad un altro.

Question

Buonasera,

  vorrei copiare e incollare dei dati da un foglio excel ad un altro come in oggetto.

Partendo dall'ottimo lavoro fatto da Mauro Gamberini, vorrei modificare la parte delle celle da copiare, evidenzio in bolt per comodità:

Public Sub m()

On Error GoTo RigaErrore

    Dim sPathNome As String

    Dim wkMe As Workbook

    Dim wk As Workbook

    Dim sh As Worksheet

    Dim shMe As Worksheet

    Dim rng As Range

    Dim lRiga As Long

    sPathNome = Application.GetOpenFilename( _

        "Excel Files (*.xls; *.xlsx; *.xlsm),*.xls; *xlsx; *.xlsm", _

        , "Selezionare il file")

    Application.ScreenUpdating = False

    Set wkMe = ThisWorkbook

    Set shMe = wkMe.Worksheets("Foglio1")

    Set wk = Workbooks.Open(sPathNome)

    Set sh = wk.Worksheets("Foglio1")

    Set rng = sh.Range("A1").CurrentRegion

rng.Copy

With shMe

lRiga = .Range("A" & .Rows.Count).End(xlUp).Row + 1

.Range("A" & lRiga).PasteSpecial

Application.CutCopyMode = False

End With

        wk.Close

    Application.ScreenUpdating = True

RigaChiusura:

    Set wkMe = Nothing

    Set shMe = Nothing

    Set wk = Nothing

    Set sh = Nothing

    Set rng = Nothing

    Exit Sub

RigaErrore:

    If Err.Number <> 1004 Then

        MsgBox Err.Number & vbNewLine & Err.Description

    End If

    Resume RigaChiusura

End Sub

Cerco di spiegare cosa devo fare:

Il mio file di partenza ha un formato standard dove gli utenti mettono dati solo in alcune celle ad esempio:

Nome foglio partenza: Tooling

Celle compilate: A2; B5; D7; E10

Il mio file di arrivo anch'esso è standard e voglio usarlo come database.

Di conseguenza voglio che all'avvio della mia macro, i campi A2; B5; D7; E10 vengano trasferiti nel nuovo file nella prima riga libera appena sotto quella compilata.

Nome foglio arrivo: Tabella_Riass

Le prime righe del file Tabella_Riass sono utilizzate come intestazione e quindi devo incominciare a scrivere dati dalla 7^ riga.

Le colonne sono 4 e partono dalla lettera C.

Le colonne sono fisse (come giusto che sia nel mio database), nella prima ad esempio, partendo da C7 dovrò avere sempre il valore A2 del foglio "Tooling".

Nella terza colonna dovrò ricopiare il valore B5 l foglio "Tooling" e cosi via.

Una volta terminata la copia salvo e la prossima volta che dovrò importare dei nuovi dati la macro deve saltare la riga appena compilata del foglio Tabella_Riass e andare a scrivere nella successiva appena sotto.

Spero di essere stato chiaro, la macro spora funziona e il fatto di selezionare il file va benissimo.

Mi manca solo questa parte che sicuramente sarà una cavolata per qualcuno di voi...

Grazie mille davvero a tutti del supporto.

Answer 1

Buonasera,

  vorrei copiare e incollare dei dati da un foglio excel ad un altro come in oggetto.

Partendo dall'ottimo lavoro fatto da Mauro Gamberini, vorrei modificare la parte delle celle da copiare, evidenzio in bolt per comodità:

Public Sub m()

On Error GoTo RigaErrore

    Dim sPathNome As String

    Dim wkMe As Workbook

    Dim wk As Workbook

    Dim sh As Worksheet

    Dim shMe As Worksheet

    Dim rng As Range

    Dim lRiga As Long

    sPathNome = Application.GetOpenFilename( _

        "Excel Files (*.xls; *.xlsx; *.xlsm),*.xls; *xlsx; *.xlsm", _

        , "Selezionare il file")

    Application.ScreenUpdating = False

    Set wkMe = ThisWorkbook

    Set shMe = wkMe.Worksheets("Foglio1")

    Set wk = Workbooks.Open(sPathNome)

    Set sh = wk.Worksheets("Foglio1")

    Set rng = sh.Range("A1").CurrentRegion

rng.Copy

With shMe

lRiga = .Range("A" & .Rows.Count).End(xlUp).Row + 1

.Range("A" & lRiga).PasteSpecial

Application.CutCopyMode = False

End With

        wk.Close

    Application.ScreenUpdating = True

RigaChiusura:

    Set wkMe = Nothing

    Set shMe = Nothing

    Set wk = Nothing

    Set sh = Nothing

    Set rng = Nothing

    Exit Sub

RigaErrore:

    If Err.Number <> 1004 Then

        MsgBox Err.Number & vbNewLine & Err.Description

    End If

    Resume RigaChiusura

End Sub

Cerco di spiegare cosa devo fare:

Il mio file di partenza ha un formato standard dove gli utenti mettono dati solo in alcune celle ad esempio:

Nome foglio partenza: Tooling

Celle compilate: A2; B5; D7; E10

Il mio file di arrivo anch'esso è standard e voglio usarlo come database.

Di conseguenza voglio che all'avvio della mia macro, i campi A2; B5; D7; E10 vengano trasferiti nel nuovo file nella prima riga libera appena sotto quella compilata.

Nome foglio arrivo: Tabella_Riass

Le prime righe del file Tabella_Riass sono utilizzate come intestazione e quindi devo incominciare a scrivere dati dalla 7^ riga.

Le colonne sono 4 e partono dalla lettera C.

Le colonne sono fisse (come giusto che sia nel mio database), nella prima ad esempio, partendo da C7 dovrò avere sempre il valore A2 del foglio "Tooling".

Nella terza colonna dovrò ricopiare il valore B5 l foglio "Tooling" e cosi via.

Una volta terminata la copia salvo e la prossima volta che dovrò importare dei nuovi dati la macro deve saltare la riga appena compilata del foglio Tabella_Riass e andare a scrivere nella successiva appena sotto.

Spero di essere stato chiaro, la macro spora funziona e il fatto di selezionare il file va benissimo.

Mi manca solo questa parte che sicuramente sarà una cavolata per qualcuno di voi...

Grazie mille davvero a tutti del supporto.

Ciao A tutti,

   sono riuscito ad andare avanti e vi posto la soluzione che ho trovato:

Sub Registrazione_Dati_DB()

    Dim sPathNome As String

    Dim WKin As Workbook          'Dichiarazione del primo file da cuai pesco i dati

    Dim WKout As Workbook       'Dichiarazione del secondo file da cui inserisco DB

    Dim shin As Worksheet           'Dichiarazione del foglio presente nel primo file

    Dim shout As Worksheet        'Dichiarazione del foglio presente nel secondo file DB  

    Dim rng As Range

    Dim lRiga As Long

    Application.ScreenUpdating = False

    'Ricerca del file con un path

    sPathNome = Application.GetOpenFilename( _

        "Excel Files (*.xls; *.xlsx; *.xlsm),*.xls; *xlsx; *.xlsm", _

        , "Selezionare il file")

     If sPathNome = "Falso" Then

        MsgBox "Operazione annullata!", vbOKOnly + vbInformation

        GoTo Chiudi

    End If

    Set WKin = Workbooks.Open(sPathNome)            'Definizione variabili di sistema per primo file

    Set WKout = ThisWorkbook                                   'Definizione variabili di sistema per secondo file

    Set shin = WKin.Worksheets("Tooling")                  'Definizione variabili di sistema per foglio del file da copiare

    Set shout = WKout.Worksheets("Change_Request")  'Definizione variabili di sistema per foglio di destinazione

    'Set rng = sh.Range("A1").CurrentRegion

    With shout

        lRiga = .Range("C" & .Rows.Count).End(xlUp).Row + 1         'Identificazione della prima riga libera

        shout.Range("C" & lRiga).Value = shin.Range("X2").Value     'metto all'interna della collona C del foglio out il valore RFT del foglio in

        shout.Range("F" & lRiga).Value = shin.Range("I5").Value     'Richiedente

        shout.Range("G" & lRiga).Value = shin.Range("P5").Value     'Funzione

        shout.Range("E" & lRiga).Value = shin.Range("AB3").Value    'Data Inizio

        shout.Range("H" & lRiga).Value = shin.Range("D8").Value     'Descrizione richiesta del cambio

        shout.Range("I" & lRiga).Value = shin.Range("X14").Value    'Cliente

        shout.Range("J" & lRiga).Value = shin.Range("X15").Value    'STI Assy codice

        shout.Range("K" & lRiga).Value = shin.Range("X16").Value    'STI Componete codice

        shout.Range("L" & lRiga).Value = shin.Range("X17").Value    'Fornitore coinvolto

        shout.Range("M" & lRiga).Value = shin.Range("X18").Value    'Approvazione cliente se richiesta

        shout.Range("N" & lRiga).Value = shin.Range("AA19").Value   'Commento richiesta approvazione cliente

        shout.Range("O" & lRiga).Value = shin.Range("I19").Value    'Commercial Request se richiesta quotazione

        shout.Range("P" & lRiga).Value = shin.Range("K19").Value    'Numero della commercial request

        shout.Range("Q" & lRiga).Value = shin.Range("P19").Value    'Quality field claim recorded

        shout.Range("R" & lRiga).Value = shin.Range("R19").Value    'NumeroQuality field claim recorded

     End With

Application.CutCopyMode = False

WKout.Save

WKin.Close

Application.ScreenUpdating = True

Chiudi:

    Set shin = Nothing

    Set shout = Nothing

    Set WKin = Nothing

    Set WKout = Nothing

End Sub