none
Copiare un Tot. numero di righe per volta ed incollarle in un altro foglio sempre in formato excel RRS feed

  • Domanda

  • Buongiorno a tutti.

    Ho un foglio di Excel che ha migliaia di righe e dovrei copiare solo 80 celle alla volta. Non sono esperto di VBA e quindi cercando su internet ho trovato una macro che mi consente di copiare in automatico ed in sequenza 80 righe alla volta ma è impostata per esportarle in un pdf.  Mi potreste aiutare a modificare questa macro in modo tale che il salvataggio non avvenga in formato pdf ma continui ad essere in formato excel? Grazie a chiunque vorrà aiutarmi. 

    '=========>>
    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"        

        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:="80", _
                Title:="NUMERO di RIGHE", _
                Type:=1)

        If iRows < 1 Then

            sMsg = "80"
            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
    '<<=========

    sabato 25 aprile 2020 13:24

Tutte le risposte