Sviluppare funzionalita su Microsoft Office con VBA Creare Nuovo File con 2 Fogli in cui Copiare Determinati Dati

LoginRegistrati
Stai vedendo 5 articoli - dal 1 a 5 (di 5 totali)
  • Autore
    Articoli
  • #24415 Risposta

    PDA
    Partecipante

      Ciao a tutti,

      Vi scrivo per un altro mio piccolo progetto.

      Nel file “Invio Scaduti Agenti x Forum” ho 3 fogli:

      -          Invio Estratti Conto;

      -          DATI CREDITI;

      -          Estratti Conto.

      Riesco a creare un altro file composto da 2 fogli dove nel primo, che voglio chiamare “Riepilogo Scaduti”, riporto la situazione generale di tutti i clienti che presentano scaduti nel foglio DATI CREDITI e la cui chiave di legame è composta dallo stesso valore presente nella colonna B del foglio DATI CREDITI e nella colonna B del foglio Invio Estratti Conto.

      Qui si presenta il primo piccolo problema:

      -          non so come dare al foglio il nome “Riepilogo Scaduti”.

       

      Il problema più grande è però quest’altro:

      riesco a creare anche un altro foglio, che però prende il nome di Foglio1, ma non riesco a copiare le righe del foglio Estratti Conto che hanno in comune il codice cliente presente nella colonna A del foglio Estratti Conto e nella colonna C del foglio DATI CREDITI, con le intestazioni già presenti nel codice VBA riportato sotto:

      Option Explicit
      
      Public Sub EstraiFileGAVconEC() 'per salvare gli estratti conto sul desktop utilizzando i ctc del foglio DATI CREDITI
      
      Dim Elenco As Collection
      Dim Agente As Variant
      Dim rAgenti, Cella, totAgenti As Range
      Dim rAgenti2, Cella2, totAgenti2 As Range
      Dim Shc, Shc1, Shc2, NewSH As Worksheet
      Dim NewWK As Workbook
      Dim sRigaBis, ur, ur1, ur2, z, sRigaTer As Long
      Dim myItem As Variant
      Dim bFound As Boolean
      Dim NomeFile As String
              
      Application.ScreenUpdating = False
      
      Set Elenco = New Collection
      Set Shc = ThisWorkbook.Sheets("DATI CREDITI")
      Set Shc1 = ThisWorkbook.Sheets("Invio Estratti Conto")
      Set Shc2 = ThisWorkbook.Sheets("Estratti Conto")
      
      ur = Shc.Range("B" & Rows.Count).End(xlUp).Row
      ur1 = Shc1.Range("B" & Rows.Count).End(xlUp).Row
      ur2 = Shc2.Range("A" & Rows.Count).End(xlUp).Row
      
      Set rAgenti = Shc1.Range(Shc1.Cells(3, 2), Shc1.Cells(ur1, 2)) 'Foglio Invio Estratti Conto
      Set totAgenti = Shc.Range(Shc.Cells(2, 2), Shc.Cells(ur, 2)) 'DATI CREDITI
      Set totAgenti2 = Shc2.Range(Shc2.Cells(2, 10), Shc2.Cells(ur2, 10)) 'Estratti Conto
      
      On Error Resume Next
      For Each Agente In rAgenti 'per ciascun codice agente del foglio Invio Estratti Conto
          If Agente.Value <> "" Then
             Elenco.Add Agente.Value 'aggiungilo ad Elenco
          Else: Agente = Agente + 1
          End If
      Next Agente
      
      On Error Resume Next
      MkDir (Environ("USERPROFILE") & "\Desktop\" & "Archivio Estratti Conto Clienti Agenti ATTIVI")
      On Error GoTo 0
      For Each myItem In Elenco
          bFound = False
          sRigaBis = 2
              For Each Cella In totAgenti
                  If Cella.Value = CVar(myItem) Then
                      If bFound = False Then
                          Set NewWK = Workbooks.Add
                         Worksheets.Add
                          Range("A1:AJ800").Select
                          'ActiveWindow.FreezePanes = True
                          Selection.Locked = False
                          Selection.FormulaHidden = False
                          
                          With Selection
                              .HorizontalAlignment = xlCenter
                              .VerticalAlignment = xlCenter
                              .EntireColumn.AutoFit
                              .WrapText = True
                              .Orientation = 0
                              .AddIndent = False
                              .IndentLevel = 0
                              .ShrinkToFit = False
                              .ReadingOrder = xlContext
                              .MergeCells = False
                          End With
                      End If 'Kiude l'If del bFound
                      bFound = True
                      Cella.EntireRow.Copy NewWK.Sheets(1).Cells(sRigaBis, 1)
                      sRigaBis = sRigaBis + 1
                  End If 'Kiude l'If del CVar
                Next Cella
              
              On Error Resume Next
              NewWK.Sheets(1).Range("A1:AJ1").Select
              Shc.Range("A1:AJ1").Copy (NewWK.Sheets(1).Range("A1"))
               Selection.AutoFilter
              NewWK.Sheets(1).Columns("B:B").EntireColumn.AutoFit
              NewWK.Sheets(1).Columns("E:E").ColumnWidth = 12.67
              NewWK.Sheets(1).Range("J1").Select
              Selection.EntireColumn.AutoFit
              NewWK.Sheets(1).Columns("C:C").EntireColumn.AutoFit
              NewWK.Sheets(1).Columns("A:AJ").EntireColumn.AutoFit
              
              z = NewWK.Sheets(1).Range("F" & Rows.Count).End(xlUp).Row
              
              NewWK.Sheets(1).Cells(z + 1, 6).Select
               Selection.Font.Bold = True
          Selection.NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
          With Selection.Font
              .Name = "Calibri"
              .FontStyle = "Grassetto"
              .Size = 12
              .Strikethrough = False
              .Superscript = False
              .Subscript = False
              .OutlineFont = False
              .Shadow = False
              .Underline = xlUnderlineStyleNone
              .ThemeColor = xlThemeColorLight1
              .TintAndShade = 0
              .ThemeFont = xlThemeFontMinor
          End With
      
      'Application.Wait Now() + TimeValue("00:00:15")
      
          bFound = False
           sRigaTer = 2
                For Each Cella In totAgenti2
                  If Cella.Value = CVar(myItem) Then
                      If bFound = False Then
                       NewWK.Sheets(2).Range("A1").Select
                          With NewWK.Sheets(2)
                              .Range("A1:J1").Value = Array( _
                                       "Codice Cliente", "Ragione Sociale", _
                                       "Data Emissione", "Data Scadenza Fattura", _
                                       "Giorni di Ritardo", "Numero di Fattura", _
                                       "Riferimento", "Importo in €", "TOTALE", "GAV")
                              .Range("A1:J1").Select
                          End With
                          Selection.Font.Bold = True
                          With Selection.Interior
                              .Pattern = xlSolid
                              .PatternColorIndex = xlAutomatic
                              .Color = 65535
                              .TintAndShade = 0
                              .PatternTintAndShade = 0
                              '.EntireColumn.AutoFit
                          End With
                          
                          Selection.AutoFilter
                          Range("A2").Select
                          ActiveWindow.FreezePanes = True
                          Rows("1:1").Select
                          Selection.Locked = False
                          Selection.FormulaHidden = False
                          With Selection
                              .HorizontalAlignment = xlCenter
                              .VerticalAlignment = xlCenter
                              .WrapText = True
                              .Orientation = 0
                              .AddIndent = False
                              .IndentLevel = 0
                              .ShrinkToFit = False
                              .ReadingOrder = xlContext
                              .MergeCells = False
                          End With
                          Selection.RowHeight = 32.25
                          Columns("A:A").ColumnWidth = 11.43
                          Columns("B:B").ColumnWidth = 19.71
                          Columns("C:C").ColumnWidth = 11
                          Columns("D:D").ColumnWidth = 13.29
                          Columns("E:E").ColumnWidth = 11.43
                          Columns("F:F").ColumnWidth = 11.14
                          Columns("G:G").ColumnWidth = 15.29
                          Columns("H:I").ColumnWidth = 15
                          Columns("H:H").ColumnWidth = 16.57
                          Columns("G:G").EntireColumn.AutoFit
                          
                     End If
                      bFound = True
                      Cella.EntireRow.Copy Sheets(2)(sRigaTer, 1)
                      sRigaTer = sRigaTer + 1
                  End If
              Next Cella
              
              NewWK.Sheets(1).Range("H2").Select
              ActiveWindow.FreezePanes = True
                  
              NomeFile = NewWK.Sheets(1).Cells(2, 1).Value & " - Ag. " & NewWK.Sheets(1).Cells(2, 2).Value
              
              On Error Resume Next
              Application.DisplayAlerts = False
                      
              NewWK.SaveAs Filename:=(Environ("USERPROFILE") & "\Desktop\" & "Archivio Estratti Conto Clienti Agenti ATTIVI\" & "RIEPILOGO POSIZIONI APERTE" & " " & NomeFile & ".xlsx") '" & myItem & " - "
             
              Application.DisplayAlerts = True
      '        NewWK.Close
         
              On Error Resume Next
              Application.DisplayAlerts = False
      
      Next myItem
      
      Set NewSH = Nothing
      Set Elenco = Nothing
      Set Cella = Nothing
      Set Shc = Nothing
      Set NewWK = Nothing
      
      Application.ScreenUpdating = True
          
      End Sub

      Allego il file principale ed il file output.

      Chiedo il Vostro prezioso e cortese aiuto, per il quale già Vi ringrazio in anticipo.

      Attendo con pazienza e curiosità.

      Grazie mille.

      Saluti,

      PDA

      Allegati:
      You must be logged in to view attached files.
      #24421 Risposta
      patel
      patel
      Moderatore
        37 pts

        a cosa servono tutti quei On Error Resume Next che hai inserito ? soltanto a non farti accorgere di eventuali errori

        #24436 Risposta

        PDA
        Partecipante

          Ciao Patel,

          ben ritrovato. Scusami per il ritardo nel riscontro.

          Faccio qualche test e ti informo.

          Grazie mille per le sempre preziose indicazioni.

          A dopo.

          Saluti,

          PDA

          #24498 Risposta

          PDA
          Partecipante

            Ciao Patel,

            ho eliminato tutti gli "On Error Resume Next " ma non è cambiato nulla   

            Non riesco ad uscirne.

            Saluti,

            PDA

            #24503 Risposta

            PDA
            Partecipante

              Ciao Patel,

              dopo vari tentativi sono riuscito a risolvere.

              Grazie mille per il tuo suggerimento.

              Alla prossima.

              Saluti,

              PDA

            LoginRegistrati
            Stai vedendo 5 articoli - dal 1 a 5 (di 5 totali)
            Rispondi a: Creare Nuovo File con 2 Fogli in cui Copiare Determinati Dati
            Gli allegati sono permessi solo ad utenti REGISTRATI
            Le tue informazioni:



            vecchio frac - 2750 risposte

            albatros54
            albatros54 - 940 risposte

            patel
            patel - 817 risposte

            Marius44
            Marius44 - 708 risposte

            Luca73
            Luca73 - 624 risposte