Macro Excel: dato un testo in una cella in alcuni file di origine, copia la riga corrispondente in un altro file excel

Question

Salve, avrei bisogno di un aiuto per creare una macro che svolga le seguenti operazioni, vi ringrazio anticipatamente.

Ho n numero di file sorgenti composti da 2 fogli, in ciascuno di essi la colonna “C” corrisponde a dei cognomi.

Ho poi dei file di destinazione ciascuno di essi si chiama come il cognome e al cui interno ci sono 2 fogli.

Vorrei poter creare una macro tale per cui se nel foglio 1 del file di origine 1 compare il cognome x, la riga corrispondente a tale cognome venga copiata in automatico nel foglio 1 del file “cognome x” corrispondente, se nel file di origine 15, al foglio 2 compare il cognome y, la riga in cui compare tale cognome venga copiata nel foglio 2 del file “cognome y”. I cognomi appaiono in molti ma non tutti i file di origine, e devono essere copiati cronologicamente riga dopo riga nel file cognome di destinazione, a partire dalla prima riga di dati libera che è la riga 4.

Potete aiutarmi?

Ringrazio anticipatamente.

Answer 1

Ciao Ale,

In un modulo standard del tuo file Personal.xlsb, incolla il seguente codice:

'=========>>

Option Explicit

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

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim SH As Worksheet

    Dim srcSH As Worksheet, srcSH2 As Worksheet

    Dim destSH As Worksheet, destSH2 As Worksheet

    Dim srcRng As Range, destRng As Range, rCell As Range

    Dim sPath As String, sStr As String

    Dim sCognome As String, sFullName As String

    Dim iRow As Long, jRow As Long

    Dim i As Long, j As Long

    Dim CalcMode As Long, NumberOfSheets As Long

    Const sPrimoFoglio As String = "Foglio1"

    Const sSecondoFoglio As String = "Foglio2"

    Const sPercorsoDestinazione As String = _

                                "C:\Users\Ale\Pippo"                      '<<=== Modifica

    Const sEstensione As String = ".xlsx"

    Set srcWB = ActiveWorkbook

    On Error GoTo XIT

    With Application

        .ScreenUpdating = False

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .EnableEvents = False

        sStr = .PathSeparator

        NumberOfSheets = .SheetsInNewWorkbook

        .SheetsInNewWorkbook = 2

    End With

    If Right(sPercorsoDestinazione, 1) = sStr Then

        sPath = sPercorsoDestinazione

    Else

        sPath = sPercorsoDestinazione & sStr

    End If

    With srcWB

        Set srcSH = .Sheets(sPrimoFoglio)

        Set srcSH2 = .Sheets(sSecondoFoglio)

    End With

    For Each SH In srcWB.Worksheets( _

        VBA.Array(srcSH.Name, srcSH2.Name))

        With SH

            iRow = LastRow(SH, .Columns("C:C"))

            On Error Resume Next

            Set srcRng = .Range("C2:C" & iRow)

            On Error GoTo XIT

            If Not srcRng Is Nothing Then

                For Each rCell In srcRng.Cells

                    With rCell

                        sCognome = .Value

                        sFullName = sPath & sCognome & sEstensione

                        If FileExists(sFullName) Then

                            Set destWB = Workbooks.Open(sFullName)

                        Else

                            Set destWB = Workbooks.Add

                            With destWB

                                .Sheets(1).Name = sPrimoFoglio

                                .Sheets(2).Name = sSecondoFoglio

                                .SaveAs Filename:=sFullName, FileFormat:=51

                            End With

                        End If

                        Set srcRng = Application.Intersect(.EntireRow, SH.UsedRange)

                    End With

                    Set destSH = destWB.Sheets(SH.Name)

                    With destSH

                        jRow = LastRow(destSH, .Columns("A:A"), 1)

                        Set destRng = .Range("A" & jRow + 1)

                    End With

                    srcRng.Copy Destination:=destRng

                    destWB.Close SaveChanges:=True

                Next rCell

            End If

        End With

        Set srcRng = Nothing

    Next SH

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

        .SheetsInNewWorkbook = NumberOfSheets

        .EnableEvents = True

    End With

End Sub

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

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

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

Public Function FileExists(FPath As String) As Boolean

    Dim FName As String

    FName = Dir(FPath)

    FileExists = FName <> ""

End Function

'<<=========

Assegna la macro Teste r a un pulsante sulla barra di accesso rapido come spiegato QUI

Per eseguire la macro, assicurarti che il file giornaliero sia il file attivo e quindi fai clic sul pulsante macro sulla barra di accesso rapido.

===

Regards,

Norman

Answer 2

No, diciamo che i file sorgenti si trovano in una directory, e i file di destinazione in un altra directory.

I file sorgenti sono composti da 2 fogli fatti da righe di dati di cui la colonna C corrisponde a un cognome. I file di destinazione  si chiamano come i cognomi che appaiono nel file di origine, hanno a loro volta 2 fogli, e la macro dovrebbe comportarsi come ho spigatosopra: per il cognomex al foglio 1, copia la riga intera nel foglio 1 del file cognomex.xls, per cognome x al foglio 2 copia l'intera riga nel foglio 2 del file cognomex.xls eccetera, per tutti i cognomi che appaiono man mano.

I file sorgenti vengono compilati a mano giorno dopo giorno, la macro deve automatizzare il processo di copia delle singole informazioni per cognome nel file del singolo cognome (per ciascuno dei 2 fogli)

Grazie per l'attenzione spero di essermi spiegato meglio

Answer 3

Ciao Ale,

Ho n numero di file sorgenti composti da 2 fogli, in ciascuno di essi la colonna “C” corrisponde a dei cognomi.

Come si farebbe ad individuare questi n file sorgenti?

I file sorgenti ei file di destinazione si trovano sulla stessa directory?

===

Regards,

Norman