Filtra e crea excel o pdf

Question

Ciao a tutti,

Ho bisogno del vostro aiuto per avere un codice che faccia quanto segue. Utilizzo una userform con listbox, text box e combobox per inserire dei dati su un foglio nascosto di nome archivio. Quello che mi serve è:

1. Poter filtrare tutte le righe del foglio archivio dalla terza in poi in base al valore che seleziono nella combobox2 e che nel foglio archivio si trovano nella colonna G.
2. Darmi la possibilità scegliendo mediante msgbox se creare una nuova cartella in formato excel oppure pdf copiando per intero le prime 2 righe e aggiungendo i dati filtrati.
3. Avere la possibilità di copiare e creare sempre in formato excel o pdf l'intero foglio se non trova nessun valore nella combobox2.
4. Infine il foglio che viene creato sia excel o pdf deve essere in orrizzontale e non verticale 

Grazie per l'attenzione che mostrerete.

Answer 1

Ciao Geacs,

Ciao Norman, ancora una volta sei stato impeccabile. Ho provato il codice e fa esattamente quello che ho chiesto nella domanda iniziale. Una sola cosa ho riscontrato da correggere, quando nella combobox non c'è nessun valore se scelgo il formato pdf sul file che crea vedo solo le righe d'intestazione, se scelgo excel la cartella creata visualizza le prime 2 righe e il filtro attivo che nasconde tutte le righe con i valori. Spero di aver spiegato bene quello che non va.

Colpa mia - avevo trascurato il caso della ComboBox vuota!

Sostituisci il codice nel modulo standard con la seguente versione nella quale le modifice sono evidenziate in grassetto:

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

Option Explicit

Public vArrCriteri() As Variant

Public Const sColonna As String = "G"

Public Const iRigaIntestazioni As Long = 2

Public Const sFoglio As String = "Archivio"

Public Const sPercorso As String = _

       "C:\Users\ndj\Documents"    '<<=== Modifica

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

Public Sub CreaElenco()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim oDic As Object

    Dim vArr As Variant

    Dim sStr As String

    Dim i As Long, LRow As Long

    Dim CalcMode As Long

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        LRow = LastRow(SH, .Columns(sColonna))

        Set Rng = .Range(sColonna & iRigaIntestazioni + 1). _

                  Resize(LRow - iRigaIntestazioni)

    End With

    vArr = Rng.Value

    Set oDic = CreateObject("Scripting.Dictionary")

    With oDic

        For i = 1 To UBound(vArr)

            sStr = vArr(i, 1)

            If Not .exists(sStr) Then

                .Add Key:=sStr, Item:=vbNullString

            End If

        Next i

    End With

    vArrCriteri = oDic.keys

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

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

Public Sub CreaPdf(sCriterio As String)

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim sStr As String

    Dim LRow As Long

    Dim OrientationMode As Long

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

      If Not sCriterio = vbNullString Then

            Set Rng = .Range(sColonna & 1)

            sStr = Rng(2).Value

            Rng.CurrentRegion.AutoFilter _

                    Field:=Rng.Column, _

                    Criteria1:=sCriterio, _

                    Operator:=xlOr, _

                    Criteria2:="=" & sStr

        End If

        With .PageSetup

            OrientationMode = .Orientation

            .Orientation = xlLandscape

        End With

        On Error GoTo XIT

        Application.ScreenUpdating = False

        .Visible = xlSheetVisible

        .ExportAsFixedFormat _

                Type:=xlTypePDF, _

                Filename:=sPercorso & SH.Name _

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

                          Quality:=xlQualityStandard, _

                          IncludeDocProperties:=True, _

                          IgnorePrintAreas:=True, _

                          OpenAfterPublish:=False

        Rng.AutoFilter

        .PageSetup.Orientation = OrientationMode

    End With

XIT:

    SH.Visible = xlSheetVeryHidden

    Application.ScreenUpdating = True

End Sub

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

Public Sub CreaFileExcel(sCriterio As String)

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim sStr As String

    Dim LRow As Long

    Dim OrientationMode As Long

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        If Not sCriterio = vbNullString Then

            Set Rng = .Range(sColonna & 1)

            sStr = Rng(2).Value

            Rng.CurrentRegion.AutoFilter _

                    Field:=Rng.Column, _

                    Criteria1:=sCriterio, _

                    Operator:=xlOr, _

                    Criteria2:="=" & sStr

            With .PageSetup

                OrientationMode = .Orientation

                .Orientation = xlLandscape

            End With

        End If

        On Error GoTo XIT

        Application.ScreenUpdating = False

        .Visible = xlSheetVisible

        .Copy

        With ActiveWorkbook

            .SaveAs Filename:=sPercorso & SH.Name _

                            & Format(Now, "yyyymmdd hh-mm") & "xlsx", _

                    FileFormat:=51

            .Close SaveChanges:=False

        End With

        Rng.AutoFilter

        .PageSetup.Orientation = OrientationMode

    End With

XIT:

    SH.Visible = xlSheetVeryHidden

    Application.ScreenUpdating = True

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

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

Ho aggiornato il mio file di prova, che troverai sempre allo stesso link.

===

Regards,

Norman

Answer 2

Ciao Norman, ancora una volta sei stato impeccabile. Ho provato il codice e fa esattamente quello che ho chiesto nella domanda iniziale. Una sola cosa ho riscontrato da correggere, quando nella combobox non c'è nessun valore se scelgo il formato pdf sul file che crea vedo solo le righe d'intestazione, se scelgo excel la cartella creata visualizza le prime 2 righe e il filtro attivo che nasconde tutte le righe con i valori. Spero di aver spiegato bene quello che non va.

Answer 3

Ciao Geacs,

Riguardo al codice postato manca pochissimo a raggiungere la mia richiesta. Ho provato anche con la tua cartella e ho notato che non mi copia le prime 2 righe. Se provi a scrivere anche nella prima riga delle intestazioni, nel file creato in pdf non appare la seconda. Io ho la necessità di visualizzare sia la prima che la seconda. Un secondo aspetto puoi fare in modo che nel momento in cui decido di creare il file mi dia la possibilità di scegliere se crearlo in pdf oppure in formato excel? Infine ho notato che se clicco sul tasto creapdf senza inserire nessun valore nella combobox lui mi crea il file vuoto con la sola riga di intestazione. A me servirebbe invece che lui crei una nuova cartella del foglio archivio. Grazie 

Nel modulo di codice della Userform, sostituisci il codice precedente con la seguente versione:

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

Option Explicit

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

Private Sub UserForm_Initialize()

    Me.cbEsci.Caption = "Esci"

    Call CreaElenco

    Me.cbCriterio.List = vArrCriteri

End Sub

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

Private Sub cbEsci_Click()

    Unload Me

End Sub

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

Private Sub cbCreaFile_Click()

    Dim Res As VbMsgBoxResult

    Res = MsgBox( _

          Prompt:="Vuoi creare il file in formato Pdf (anzichè formato Excel)?", _

          Buttons:=vbYesNoCancel, _

          Title:="Crea File")

    Select Case Res

    Case vbYes

        Call CreaPdf(Me.cbCriterio.Value)

    Case vbNo

        Call CreaFileExcel(Me.cbCriterio.Value)

    Case vbCancel

        Call MsgBox(Prompt:="Hai cancellato", _

                    Buttons:=vbInformation, _

                    Title:="Operazione cancellata!")

    End Select

End Sub

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

Nel modulo standard sostituisci il codice con:

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

Option Explicit

Public vArrCriteri() As Variant

Public Const sColonna As String = "G"

Public Const iRigaIntestazioni As Long = 2

Public Const sFoglio As String = "Archivio"

Public Const sPercorso As String = _

                           "C:\Utenti\Geacs\Documenti**"                  '<<=== Modifica**

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

Public Sub CreaElenco()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim oDic As Object

    Dim vArr As Variant

    Dim sStr As String

    Dim i As Long, LRow As Long

    Dim CalcMode As Long

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        LRow = LastRow(SH, .Columns(sColonna))

        Set Rng = .Range(sColonna & iRigaIntestazioni + 1). _

                  Resize(LRow - iRigaIntestazioni)

    End With

    vArr = Rng.Value

    Set oDic = CreateObject("Scripting.Dictionary")

    With oDic

        For i = 1 To UBound(vArr)

            sStr = vArr(i, 1)

            If Not .exists(sStr) Then

                .Add Key:=sStr, Item:=vbNullString

            End If

        Next i

    End With

    vArrCriteri = oDic.keys

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

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

Public Sub CreaPdf(sCriterio As String)

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim sStr As String

    Dim LRow As Long

    Dim OrientationMode As Long

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        Set Rng = .Range(sColonna & 1)

        sStr = Rng(2).Value

        Rng.CurrentRegion.AutoFilter _

                Field:=Rng.Column, _

                Criteria1:=sCriterio, _

                Operator:=xlOr, _

                Criteria2:="=" & sStr

        With .PageSetup

            OrientationMode = .Orientation

            .Orientation = xlLandscape

        End With

        On Error GoTo XIT

        Application.ScreenUpdating = False

        .Visible = xlSheetVisible

        .ExportAsFixedFormat _

                Type:=xlTypePDF, _

                Filename:=sPercorso & SH.Name _

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

                          Quality:=xlQualityStandard, _

                          IncludeDocProperties:=True, _

                          IgnorePrintAreas:=True, _

                          OpenAfterPublish:=False

        Rng.AutoFilter

        .PageSetup.Orientation = OrientationMode

    End With

XIT:

    SH.Visible = xlSheetVeryHidden

    Application.ScreenUpdating = True

End Sub

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

Public Sub CreaFileExcel(sCriterio As String)

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim sStr As String

    Dim LRow As Long

    Dim OrientationMode As Long

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        Set Rng = .Range(sColonna & 1)

        sStr = Rng(2).Value

        Rng.CurrentRegion.AutoFilter _

                Field:=Rng.Column, _

                Criteria1:=sCriterio, _

                Operator:=xlOr, _

                Criteria2:="=" & sStr

        With .PageSetup

            OrientationMode = .Orientation

            .Orientation = xlLandscape

        End With

        On Error GoTo XIT

        Application.ScreenUpdating = False

        .Visible = xlSheetVisible

        .Copy

        With ActiveWorkbook

            .SaveAs Filename:=sPercorso & SH.Name _

                            & Format(Now, "yyyymmdd hh-mm") & "xlsx", _

                    FileFormat:=51

            .Close SaveChanges:=False

        End With

        Rng.AutoFilter

        .PageSetup.Orientation = OrientationMode

    End With

XIT:

    SH.Visible = xlSheetVeryHidden

    Application.ScreenUpdating = True

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

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

Ho aggiornato il mio file di prova Geacs20160515.xlsm che puoi scaricare allo stesso link:

https://www.dropbox.com/s/dwgwn8k6vq54yny/Geacs20160515.xlsm?dl=0

===

Regards,

Norman

Answer 4

Ciao Norman e grazie per la risposta, si credo che tu conosca il mio progetto meglio di chiunque altro, ti assicuro anche che ne faccio largo uso e mi fa risparmiare moltissimo tempo. Riguardo al codice postato manca pochissimo a raggiungere la mia richiesta. Ho provato anche con la tua cartella e ho notato che non mi copia le prime 2 righe. Se provi a scrivere anche nella prima riga delle intestazioni, nel file creato in pdf non appare la seconda. Io ho la necessità di visualizzare sia la prima che la seconda. Un secondo aspetto puoi fare in modo che nel momento in cui decido di creare il file mi dia la possibilità di scegliere se crearlo in pdf oppure in formato excel? Infine ho notato che se clicco sul tasto creapdf senza inserire nessun valore nella combobox lui mi crea il file vuoto con la sola riga di intestazione. A me servirebbe invece che lui crei una nuova cartella del foglio archivio. Grazie

Answer 5

Ciao Geacs,

Ho bisogno del vostro aiuto per avere un codice che faccia quanto segue. Utilizzo una userform con listbox, text box e combobox per inserire dei dati su un foglio nascosto di nome archivio. Quello che mi serve è:

1. Poter filtrare tutte le righe del foglio archivio dalla terza in poi in base al valore che seleziono nella combobox2 e che nel foglio archivio si trovano nella colonna G.
2. Darmi la possibilità scegliendo mediante msgbox se creare una nuova cartella in formato excel oppure pdf copiando per intero le prime 2 righe e aggiungendo i dati filtrati.
3. Avere la possibilità di copiare e creare sempre in formato excel o pdf l'intero foglio se non trova nessun valore nella combobox2.
4. Infine il foglio che viene creato sia excel o pdf deve essere in orrizzontale e non verticale 

Per riferimento futuro, ti chiederei di fornire sempre un esempio del tuo file, al fine di consentire a coloro che vogliono aiutare a essere in grado di fornire tale assistenza, senza la necessità di imaginare e creare una cartella di lavoro alla cieca. Credo sia probabile che io conosca il tuo progetto  almeno altrettanto bene che  chiunque  ma anch'io faccio molto fatica a volte a immaginare che cosa tu stia  facendo! Ti assicuro che faccio queste osservazioni senza qualunque malizia e solo in un tentativo di essere costruttivo: più è facile aiutarti, più probabile sia l'assistenza!

Detto questo, prova quanto segue. In un modulo standard, incolla il seguente codice: 

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

Option Explicit

Public vArrCriteri() As Variant

Public Const sColonna As String = "G"

Public Const iRigaIntestazioni As Long = 2

Public Const sFoglio As String = "Archivio"

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

Public Sub CreaElenco()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, rCell As Range

    Dim oDic As Object

    Dim vArr As Variant

    Dim sStr As String

    Dim i As Long, LRow As Long

    Dim CalcMode As Long

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        LRow = LastRow(SH, .Columns(sColonna))

        Set Rng = .Range(sColonna & iRigaIntestazioni + 1). _

                  Resize(LRow - iRigaIntestazioni)

    End With

    vArr = Rng.Value

    Set oDic = CreateObject("Scripting.Dictionary")

    With oDic

        For i = 1 To UBound(vArr)

            sStr = vArr(i, 1)

            If Not .exists(sStr) Then

                .Add Key:=sStr, Item:=vbNullString

            End If

        Next i

    End With

    vArrCriteri = oDic.keys

XIT:

    With Application

        .Calculation = CalcMode

        .ScreenUpdating = True

    End With

End Sub

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

Public Sub CreaPdf(sCriterio As String)

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range, Rng2 As Range

    Dim LRow As Long

    Dim OrientationMode As Long

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    With SH

        Set Rng = .Range(sColonna & iRigaIntestazioni)

        Rng.CurrentRegion.AutoFilter _

                Field:=Rng.Column, _

                Criteria1:=sCriterio

        With .PageSetup

            OrientationMode = .Orientation

            .Orientation = xlLandscape

        End With

        On Error GoTo XIT

        Application.ScreenUpdating = False

        .Visible = xlSheetVisible

        .ExportAsFixedFormat _

                Type:=xlTypePDF, _

                Filename:=SH.Name & Format(Now, "yyyymmdd hh-mm") & ".pdf", _

                Quality:=xlQualityStandard, _

                IncludeDocProperties:=True, _

                IgnorePrintAreas:=True, _

                OpenAfterPublish:=False

        Rng.AutoFilter

        .PageSetup.Orientation = OrientationMode

    End With

XIT:

SH.Visible = xlSheetVeryHidden

Application.ScreenUpdating = True

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

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

Nel modulo di codice della Useform, incolla:

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

Option Explicit

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

Private Sub UserForm_Initialize()

    Me.cbEsci.Caption = "Esci"

    Call CreaElenco

    Me.cbCriterio.List = vArrCriteri

End Sub

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

Private Sub cbEsci_Click()

    Unload Me

End Sub

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

Private Sub CommandButton1_Click()

    Call CreaPdf(Me.cbCriterio.Value)

End Sub

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

Potresti scaricare il mio file di prova Geacs20160515.xlsm a:

https://www.dropbox.com/s/dwgwn8k6vq54yny/Geacs20160515.xlsm?dl=0

Buona Domenica.

===

Regards,

Norman