Come dividere un file di excel con moltissime righe i tanti files di excel più piccoli

Question

Buon pomeriggio a tutti.

Sto lavorando con alcuni file di excel troppo grandi e mi trovo in difficoltà per questo richiedo il vostro aiuto.

Ho un grosso file di excel con più di 10mila righe (unico worksheet), chiamato XY.xls e lo vorrei suddividere in "n" files XY_01.xls, XY_02.xls, XY_03.xls, ecc.

La prima riga del file XY contiene sempre le intestazioni di colonna ed avrei bisogno che il modulo mi chiedesse: ogni quante righe vuoi eseguire lo split?

L'operatore inserisce un numero (ad esempio 200)

La macro allora genera tanti xls da 200 righe (nella prima riga sempre la stessa intestazione), e li salva con il nome che ho descritto prima nella stessa cartella del file originario.

Il processo termina non appena trovo una riga blank nel file originario XY.

Ringrazio in anticipo chi potrà darmi una mano.

Giovanni Carnevale

Answer 1

Ciao Giovanni,

Per affrontare due problemi con il codice suggerito da me, prova invece la seguente versione:

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

Option Explicit

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

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, copyRng As Range

    Dim destRng As Range, RngIntestazioni As Range

    Dim arrFile() As Variant

    Dim sPrefisso As String, sPercorso As String, sFilename As String

    Dim Res As Variant

    Dim i As Long, iCtr As Long, iStep As Long

    Dim LRow As Long, LCol As Long

    Dim CalcMode As Long

    Res = InputBox("Quante righe vuoi nei nuovi file?")

    If IsNumeric(Res) Then

        iStep = CLng(Res)

    Else

        Call MsgBox( _

             Prompt:="Non hai precisato il numero di righe. Riprova!", _

             Buttons:=vbInformation, _

             Title:="PROBLEMA")

        Exit Sub

    End If

   Set srcWB = ThisWorkbook

    With srcWB

        Set srcSH = .Sheets(1)

        sPercorso = .Path & Application.PathSeparator

        sPrefisso = Split(.Name, ".")(0) & "_"

    End With

    With srcSH

        LRow = LastRow(srcSH)

        LCol = LastCol(srcSH)

        Set srcRng = .Range("A2").Resize(LRow - 1, LCol)

        Set RngIntestazioni = srcRng.Rows(0)

    End With

    For i = 1 To LRow - iStep Step iStep

        iCtr = iCtr + 1

        Set destWB = Workbooks.Add(xlWBATWorksheet)

        Set copyRng = srcRng.Rows(i).Resize(iStep)

        Set destSH = destWB.Sheets(1)

        Set destRng = destSH.Range("A2")

        On Error GoTo XIT

        With Application

            CalcMode = .Calculation

            .Calculation = xlCalculationManual

            .ScreenUpdating = False

        End With

        With destRng

            RngIntestazioni.Copy

            With .Cells(0)

                .PasteSpecial Paste:=8

                .PasteSpecial xlPasteValues, , False, False

                .PasteSpecial xlPasteFormats, , False, False

            End With

            copyRng.Copy

            With .Cells(1)

                .PasteSpecial xlPasteValues, , False, False

                .PasteSpecial xlPasteFormats, , False, False

            End With

        End With

        With destWB

        sFilename = sPercorso & sPrefisso & Format(iCtr, "00")

            .SaveAs sFilename

            ReDim Preserve arrFile(1 To iCtr)

            arrFile(iCtr) = sFilename

            .Close

        End With

    Next i

        Call MsgBox( _

             Prompt:="I seguenti file sono stati creati e salvati:" _

             & vbNewLine & vbNewLine _

             & Join(arrFile, vbNewLine), _

             Buttons:=vbInformation, _

             Title:="REPORT")

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = 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 LastCol(SH As Worksheet, _

                        Optional Rng As Range)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

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

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByColumns, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Column

    On Error GoTo 0

End Function

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

===

Regards,

Norman

Answer 2

Ciao Norman,

ho provato entrambi i codici, sono quasi perfetti per risolvere il mio problema, grazie.

Nel mio caso preferisco il secondo codice (immissione dell'operatore del numero di righe da splittare).

C'è però un problema:

ho suddiviso ul file da 700 righe:

con il primo modulo vengono creati 4 files:

il primo da 200...ok

il secondo da 200...ok

il terzo da 98...???

il quarto vuoto...???

Anche con il secondo modulo, immetto manualmente il numero di righe (150) ed ottengo 4 files (invece dovevano essere 5):

il primo da 150...ok

il secondo da 150...ok

il terzo da 150...ok

il quarto 150...ok

manca il quinto file con le righe residue per arrivare alle 700 originarie.

Cortesemente puoi controllare anche tu?

Grazie infinite.

Giovanni

Answer 3

Ciao Giovanni,

Sto lavorando con alcuni file di excel troppo grandi e mi trovo in difficoltà per questo richiedo il vostro aiuto.

Ho un grosso file di excel con più di 10mila righe (unico worksheet), chiamato XY.xls e lo vorrei suddividere in "n" files XY_01.xls, XY_02.xls, XY_03.xls, ecc.

La prima riga del file XY contiene sempre le intestazioni di colonna ed avrei bisogno che il modulo mi chiedesse: ogni quante righe vuoi eseguire lo split?

L'operatore inserisce un numero (ad esempio 200)

La macro allora genera tanti xls da 200 righe (nella prima riga sempre la stessa intestazione), e li salva con il nome che ho descritto prima nella stessa cartella del file originario.

Il processo termina non appena trovo una riga blank nel file originario XY.

Prova qualcosa del genere:

• Alt+F11 per aprire l'editor di VBA
• Alt+IMper inserire un nuovo modulo di codice
• Nel nuovo modulo vuoto, incolla il seguente codice:

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

Option Explicit

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

Public Sub Tester()

    Dim srcWB As Workbook, destWB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim srcRng As Range, destRng As Range, RngIntestazioni As Range

    Dim arrFile() As Variant

    Dim sPrefisso As String, sPercorso As String, sFilename As String

    Dim i As Long, iCtr As Long

    Dim LRow As Long, LCol As Long

    Dim CalcMode As Long

    Set srcWB = ThisWorkbook

    With srcWB

        Set srcSH = .Sheets(1)

        sPercorso = .Path & Application.PathSeparator

        sPrefisso = Split(.Name, ".")(0) & "_"

    End With

    With srcSH

        LRow = LastRow(srcSH)

        LCol = LastCol(srcSH)

        Set srcRng = .Range("A1").Resize(LRow, LCol)

        Set RngIntestazioni = srcRng.Rows(1)

    End With

    For i = 2 To LRow Step 200

        iCtr = iCtr + 1

        Set destWB = Workbooks.Add(xlWBATWorksheet)

        Set srcRng = srcRng.Rows(i).Resize(200)

        Set destSH = destWB.Sheets(1)

        Set destRng = destSH.Range("A2")

        On Error GoTo XIT

        With Application

            CalcMode = .Calculation

            .Calculation = xlCalculationManual

            .ScreenUpdating = False

        End With

        With destRng

            RngIntestazioni.Copy

            With .Cells(0)

                .PasteSpecial Paste:=8

                .PasteSpecial xlPasteValues, , False, False

                .PasteSpecial xlPasteFormats, , False, False

            End With

            srcRng.Copy

            With .Cells(1)

                .PasteSpecial xlPasteValues, , False, False

                .PasteSpecial xlPasteFormats, , False, False

            End With

        End With

        With destWB

        sFilename = sPercorso & sPrefisso & Format(iCtr, "00")

            .SaveAs sFilename

            ReDim Preserve arrFile(1 To iCtr)

            arrFile(iCtr) = sFilename

            .Close

        End With

    Next i

        Call MsgBox( _

             Prompt:="I seguenti file sono stati creati e salvati:" _

             & vbNewLine & vbNewLine _

             & Join(arrFile, vbNewLine), _

             Buttons:=vbInformation, _

             Title:="REPORT")

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = 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 LastCol(SH As Worksheet, _

                        Optional Rng As Range)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

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

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByColumns, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Column

    On Error GoTo 0

End Function

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

• Alt+Q per chiudere l'editor di VBA e tornare a Excel
• Salva il file con l’estensione xlsm
• Alt+F8 per aprire  la finestra di gestione delle macro
• Seleziona Tester | Esegui

===

Regards,

Norman