Copiare un Tot. numero di righe per volta ed incollarle in un altro foglio per poi esportarli in formato PDF.

Question

Buongiorno a tutti.

Ho un foglio di Excel (come da immagine sottoriportata) che ha migliaia di righe e che possono variare di volta in volta ( cioè possono andare da 100 fino a 10000).

Desidero creare un ciclo che mi copi un numero specifico di righe ( magari tramite input box oppure tramite un dato da inserire in una cella, per esempio decidere se copiare 60, 90, 150 righe per volta) e da queste righe mi crei un File Pdf da salvare in una cartella specifica.

Il ciclo dovrebbe scorrere in progressione tutte le righe del Foglio di Excel e in base al numero di righe selezionate (per esempio se decido di selezionare e copiare il contenute di  90 righe per volta) dovrebbe creare tanti files quanti sono i dati che verrebbero esportati con quel tipo di impostazione.

Per esempio supponiamo di avere un foglio con 5400 righe di dati, se decido di selezionare e copiare i dati di 90 righe per volta dovrebbero essere creati 60 file PDF ( perché 5400/90=60).

Sono riuscito da solo a creare la routine che allego ma non riesco ad inserirla in un ciclo che faccia tutto da solo, secondo quanto ho già specificato.

Sub Copia90Righe()

    Dim sh1 As Worksheet, sh2 As Worksheet

    Dim i As Long, j As Long

    Set sh1 = Sheets("Foglio2")

    Set sh2 = Sheets("Foglio3")

    i = 1

    For j = 1 To Rows.count ' 1 prende anche l'intestazione di colonna ecco perchè ho messo 92 per avere 90 domande esatte

        If sh1.Cells(j, 1).EntireRow.Hidden = False Then

            sh1.Cells(j, 1).EntireRow.Copy sh2.Cells(i, 1)

            i = i + 1

            If i = 92 Then Exit Sub

        End If

    Next j

MsgBox " Ho Finito"

End Sub

Spero di essere stato chiaro e comprensibile.

Ciao Nicola.

Answer 1

Ciao Nichi,

per questo tipo di problema ti consiglio di visitare questo forum, dedicato a privati, per questioni specifiche come VBA , perciò puoi fare qui domande più specifiche , cliccando su questo link .

Fammi sapere se hai bisogno di ulteriori domande

Saluti

Claudio

Answer 2

Ciao Norman, ti ho preparato il file originale con annessa disposizione dei dati, sul quale ho creato una routine che mi acquisisce i file Word di una directory (di cui abbiamo discusso giorni fa) richiamata da un pulsante di comando  con Caption: Importa file WORD.

Poi ho creato un altro pulsante di comando con Caption: CREA PDF dal quale lancio la tua routine.

Il tuo codice va benissimo, penso che sia da implementare e migliorare la routine: ImportWordToExcel dopo aver acquisto i file di word in Excel formattando le colonne in modo da poter contenere i dati senza troncarli per poi esportarli con la tua routine come da file chiamato:  FAC simile del file pdf da creare allegato nel sottoelencato link.

Ti allego pure tutti i files di word che importo in Excel in modo che spiego meglio la procedura e ciò di cui stiamo discutendo.

Spero di essere stato chiaro Norman, ti prego chiedimi pure altre informazioni se non sono stato chiaro, poiché ci siamo quasi al raggiungimento del mio obiettivo.

Il link dove pubblico: il file di Excel, I files di Word ed il fac simile di come dovrebbero apparire i Pdf alla fine della tua routine è il seguente: https://1drv.ms/f/s!Ali6qqOH3dOAiGuAV1qNvri91e4N

P.S. se ti va continuiamo con la precedente discussione manca pochissimo per portarla a termine, hai già tutto qui pubblicato, devo solo fornirti pochi dettagli.

Grazie infinite per tutto.

Resto in attesa di tuoi dettagli, Norman.

Ciao Nicola.

Answer 3

Ciao Nicola,

Ciao Norman, grazie per la tua presenza.

Tutto ok il tuo codice va benissimo, solo il problema della formattazione dei dati nei Files pdf, vedi immagine di uno  di loro, il testo non è leggibile, come fare per far legger il testo bene su ogni file pdf?

Con il mio file di prova  ei miei dati non riscontro alcun problema. Comunque, come sempre, sarebbe consigliabile caricare un file di esempio in modo che si possa provare una soluzione con la vera configurazione di dati.

===

Regards,

Norman

Answer 4

Ciao Norman, grazie per la tua presenza.

Tutto ok il tuo codice va benissimo, solo il problema della formattazione dei dati nei Files pdf, vedi immagine di uno  di loro, il testo non è leggibile, come fare per far legger il testo bene su ogni file pdf?

Ciao Nicola.

Answer 5

Ciao Nicola,

Prova qualcosa del genere:

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

Option Explicit

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

Public Sub Tester()

    Dim WB As Workbook

    Dim srcSH As Worksheet, destSH As Worksheet

    Dim Rng As Range, rngCopy As Range

    Dim rngHeaders As Range

    Dim arrHeaders As Variant, arrPdf() As Variant

    Dim Res As Variant

    Dim sStr As String, sPercorso As String, sFullname As String

    Dim sMsg As String, sTitle As String

    Dim iButtons As Long

    Dim i As Long, iCtr As Long

    Dim LRow As Long, iRows As Long

    Dim CalcMode As Long

    Const sFoglio As String = "Foglio1"        '<<=== Modifica

    Set WB = ThisWorkbook

    Set srcSH = WB.Sheets(sFoglio)

    On Error GoTo XIT

    With Application

        CalcMode = .Calculation

        .Calculation = xlCalculationManual

        .ScreenUpdating = False

    End With

    With srcSH

        LRow = LastRow(srcSH, .Columns("A:A"))

        Set Rng = .Range("A2:G" & LRow)

    End With

    Set rngHeaders = Rng.Rows(0)

    arrHeaders = rngHeaders.Value

    iRows = Application.InputBox( _

            Prompt:="Quante righe devono essere copiate per ogni file pdf", _

            Title:="NUMERO di RIGHE", _

            Type:=1)

    If iRows < 1 Then

        sMsg = "Non hai precisato un numero valido"

        iButtons = vbInformation

        sTitle = "CODICE TERMINATO"

        GoTo XIT

    End If

    sPercorso = GetDirectory

    If sPercorso = vbNullString Then

        sMsg = "Non hai scelto una directory ! "

        sTitle = "CODICE TERMINATO !"

        iButtons = vbCritical

        GoTo XIT

    Else

        sPercorso = sPercorso & Application.PathSeparator

    End If

    Set destSH = WB.Sheets.Add

    destSH.Range("A1").Resize(1, UBound(arrHeaders, 2)).Value = arrHeaders

    For i = 1 To Rng.Rows.Count Step iRows

        iCtr = iCtr + 1

        destSH.UsedRange.Offset(1).ClearContents

        Rng.Rows(i).Resize(iRows).Copy Destination:=destSH.Range("A2")

        sFullname = sPercorso & "#" & iCtr & "_" _

                    & Format(Now, "yyyymmdd hh-mm") & "pdf"

        ReDim Preserve arrPdf(1 To iCtr)

        arrPdf(iCtr) = sFullname

        Call SalvaPdf(destSH, sFullname)

    Next i

    sStr = Join(arrPdf, vbNewLine)

    sMsg = "I seguenti " & iCtr _

           & " file pdf sono stato salvati nella directory " _

           & sPercorso & ":" _

           & vbNewLine & vbNewLine & sStr

    sTitle = "REPORT"

    iButtons = vbInformation

    Application.DisplayAlerts = False

    destSH.Delete

XIT:

    Call MsgBox( _

         Prompt:=sMsg, _

         Buttons:=iButtons, _

         Title:=sTitle)

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

        .DisplayAlerts = True

    End With

End Sub

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

Public Sub SalvaPdf(aSH As Worksheet, sNomePDF)

    With aSH

        With .PageSetup

            .Orientation = xlPortrait

            .Zoom = False

            .FitToPagesWide = False

            .FitToPagesTall = False

        End With

        .ExportAsFixedFormat _

                Type:=xlTypePDF, _

                Filename:=sNomePDF & ".pdf", _

                Quality:=xlQualityStandard, _

                IncludeDocProperties:=True, _

                IgnorePrintAreas:=False, _

                OpenAfterPublish:=False

    End With

End Sub

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

Public Function GetDirectory() As String

    Dim oShellApp As Object

    Dim oFSO As Object

    Dim sPercorso As String

    Dim bProblem As Boolean

    Set oFSO = CreateObject("Scripting.FileSystemObject")

    Do

        bProblem = False

        Set oShellApp = CreateObject("Shell.Application"). _

                        Browseforfolder(0, "SELEZIONA UNA FOLDER", 0, "c:\")

        On Error Resume Next

        sPercorso = oShellApp.self.Path

        If Err.Number <> 0 Then

            If MsgBox(Prompt:="Non hai scelto una cartella valida!" _

                              & vbNewLine & vbNewLine & _

                              "Vuoi riprovare?", _

                      Buttons:=vbYesNoCancel, _

                      Title:="CARTELLA NECESSARIA !") <> vbYes Then

                Exit Function

            End If

            bProblem = True

        End If

        On Error GoTo 0

    Loop Until bProblem = False

    GetDirectory = sPercorso

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

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

===

Regards,

Norman