trasferimento record da un foglio al successivo – Pagina 2

Stai vedendo 6 articoli - dal 26 a 31 (di 31 totali)

← 1 2

Autore

Articoli

02/05/2025 alle 23:19 #52202 Score: 0 | Risposta

Frasubb

Partecipante

Karma: 1 pt

ah scusa Alex ... dimenticavo

Quando vado a trasferire da mese precedente a successivo, in questo trovo i dati trasferiti ma mi rimangono selezionate tutti i dati riportati nel foglio.

Si potrebbe invece selezionare, subito dopo aver trasferito, la cella di colonna "A" della riga immediatamente sotto all'ultima contenente dati ?

Thanks

03/05/2025 alle 12:23 #52207 Score: 1 | Risposta

alexps81

Moderatore

Karma: 56 pts

Ciao @frasubb

Ti giro il codice aggiornato. Se gira bene come volevi, ti devo chiedere di concludere questa "discussione" in quanto siamo andati ben oltre lo "spirito" del Forum

Sub Transfert()
    Dim wsSuccessivo As Worksheet, ws As Worksheet
    Dim wb As Workbook, wbNew As Workbook
    Dim Codice As Variant, mesi As Variant, parti As Variant
    Dim CellaW As Range, rng As Range
    Dim meseAttuale As String, meseSuccessivo As String, firstAddress As String
    Dim percorsoFile As String, nomeFile As String, nuovoFile As String
    Dim i As Byte, ur As Long, nuovoAnno As Integer, errNumber As Long
    Dim appenaCreato As Boolean

    On Error GoTo GestErr

    Application.ScreenUpdating = False
    Set wb = ThisWorkbook

    mesi = Array("Gennaio", "Febbraio", "Marzo", "Aprile", "Maggio", "Giugno", _
                 "Luglio", "Agosto", "Settembre", "Ottobre", "Novembre", "Dicembre")

    meseAttuale = wb.ActiveSheet.Name

    For i = LBound(mesi) To UBound(mesi)
        If StrComp(meseAttuale, mesi(i)) = 0 Then
            meseSuccessivo = mesi((i + 1) Mod 12)
            Exit For
        End If
    Next i

    If meseAttuale = "Dicembre" Then
        appenaCreato = False
        percorsoFile = wb.Path & "\"
        nomeFile = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
        parti = Split(nomeFile, "-")
        nuovoAnno = parti(UBound(parti)) + 1
        nuovoFile = Left(nomeFile, Len(nomeFile) - Len(parti(UBound(parti)))) & nuovoAnno & ".xlsm"

        If MsgBox("Attenzione...stai trasferendo i dati del mese di Dicembre." & String(2, vbCrLf) & _
               "Questi dati verranno cancellati da questo file e trasferiti nel Foglio di Gennaio del file dell'anno successivo a questo." & String(2, vbCrLf) & _
               "Se il file non esiste allora verrà creato identico a questo ma relativo all'anno " & nuovoAnno & " ma ripulito di dati. Se esiste allora i dati verranno accodati a quelli già esistenti.", _
               vbQuestion + vbYesNo, "Sposta dati") = vbNo Then
            errNumber = 1000
            GoTo GestErr
        End If

        If Dir(percorsoFile & nuovoFile) = "" Then
            'il file non esiste allora crealo e aprilo
            appenaCreato = True
            wb.SaveCopyAs (percorsoFile & nuovoFile)
            Set wbNew = Workbooks.Open(percorsoFile & nuovoFile)

            For Each ws In wbNew.Worksheets
                For i = LBound(mesi) To UBound(mesi)
                    If StrComp(ws.Name, mesi(i)) = 0 Then
                        ur = ws.Cells(Rows.Count, "A").End(xlUp).Row
                        If ur > 1 Then
                            On Error Resume Next
                            Set rng = ws.Range("A2:R" & ur).SpecialCells(xlCellTypeConstants) '<--cancello il contenuto solo delle celle senza formule
                            On Error GoTo 0
                            If Not rng Is Nothing Then
                                Application.EnableEvents = False
                                rng.ClearContents
                                Application.EnableEvents = True
                            End If
                        End If
                        Exit For
                    End If
                Next i
            Next ws
        Else
            'file esiste allora aprilo
            Set wbNew = Workbooks.Open(percorsoFile & nuovoFile)
        End If

        Set wsSuccessivo = Nothing
        On Error Resume Next
        Set wsSuccessivo = wbNew.Worksheets(meseSuccessivo)
        On Error GoTo 0
        
        If wsSuccessivo Is Nothing Then
            MsgBox "Il foglio con il nome " & meseSuccessivo & " NON esiste", vbCritical
            errNumber = 1000
            GoTo GestErr
        End If
    Else
        Set wsSuccessivo = Nothing
        On Error Resume Next
        Set wsSuccessivo = wb.Worksheets(meseSuccessivo)
        On Error GoTo 0
        
        If wsSuccessivo Is Nothing Then
            MsgBox "Il foglio con il nome " & meseSuccessivo & " NON esiste", vbCritical
            errNumber = 1000
            GoTo GestErr
        End If
    End If

    Do
        Codice = Application.InputBox("Inserire codice Contatore", "InserireCodice", Type:=1) '<--Type = 1 accetta solo numeri
        If Codice = False Then
            On Error Resume Next
            wbNew.Close False
            On Error GoTo 0
            If appenaCreato Then
                On Error Resume Next
                Kill (percorsoFile & nuovoFile)
                On Error GoTo 0
            End If
            errNumber = 1000
            GoTo GestErr
        End If

        ur = wsSuccessivo.Cells(Rows.Count, "A").End(xlUp).Row

        Set CellaW = wb.Worksheets(meseAttuale).Range("A:A").Find(What:=Codice, LookIn:=xlValues, LookAt:=xlWhole)
        If Not CellaW Is Nothing Then
            firstAddress = CellaW.Address
            Do
                ur = ur + 1

                Application.EnableEvents = False
                With wsSuccessivo
                    .Range("A" & ur & ":F" & ur).Value = wb.Worksheets(meseAttuale).Range("A" & CellaW.Row & ":F" & CellaW.Row).Value
                    .Range("H" & ur & ":J" & ur).Value = wb.Worksheets(meseAttuale).Range("H" & CellaW.Row & ":J" & CellaW.Row).Value
                    .Range("L" & ur & ":M" & ur).Value = wb.Worksheets(meseAttuale).Range("L" & CellaW.Row & ":M" & CellaW.Row).Value
                    .Range("O" & ur & ":R" & ur).Value = wb.Worksheets(meseAttuale).Range("O" & CellaW.Row & ":R" & CellaW.Row).Value

                    If .Cells(ur, "K").Value > 0 And UCase(.Cells(ur, "M").Value) = "SI" Then
                        .Cells(ur, "F").Value = DateAdd("m", 1, .Cells(ur, "F"))
                    End If
                End With

                Set CellaW = wb.Worksheets(meseAttuale).Range("A:A").FindNext(CellaW)
            Loop While Not CellaW Is Nothing And CellaW.Address <> firstAddress
        Else
            MsgBox ("Codice Non Trovato")
        End If

    Loop While MsgBox("Finito!" & String(2, vbCrLf) & "Vuoi inserire un altro codice?", vbYesNo + vbQuestion, "PROSEGUO O ESCO?") = vbYes

    'Sort finale
    With wsSuccessivo
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=.Range("B1:B" & ur), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange wsSuccessivo.Range("A1:R" & ur)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Select
        .Range("A" & ur + 1).Select
    End With

    Application.EnableEvents = True
    Application.ScreenUpdating = True

safetyExit:
    Set CellaW = Nothing
    Set wbNew = Nothing
    Set wsSuccessivo = Nothing
    Set ws = Nothing
    Set wb = Nothing
    Set rng = Nothing
    Exit Sub

GestErr:
    If errNumber <> 1000 Then
        MsgBox "Attenzione...errore nr: " & Err.Number & " - " & Err.Description, vbCritical, "Gestione errori"
    End If
    Err.Clear
    GoTo safetyExit
End Sub

03/05/2025 alle 14:40 #52213 Score: 0 | Risposta

Frasubb

Partecipante

Karma: 1 pt

Grazie Alex, hai ragione e mi scuso se mi sono dilungato nel chiedere.

27/12/2025 alle 21:02 #54179 Score: 0 | Risposta

Frasubb

Partecipante

Karma: 1 pt

Scusa Alex,

se sono posizionato nel foglio "Dicembre" e voglio trasferire i dati a gennaio (ovviamente del mese successivo), mi da un errore del tipo "errore n. 13 - Tipo non corrispondente"

Che devo fare ?

Inserisco il codice VBA

Grazie mille

Sub Transfert()
    Dim wsSuccessivo As Worksheet, ws As Worksheet
    Dim wb As Workbook, wbNew As Workbook
    Dim Codice As Variant, mesi As Variant, parti As Variant
    Dim CellaW As Range, rng As Range
    Dim meseAttuale As String, meseSuccessivo As String, firstAddress As String
    Dim percorsoFile As String, nomeFile As String, nuovoFile As String
    Dim i As Byte, ur As Long, nuovoAnno As Integer, errNumber As Long
    Dim appenaCreato As Boolean

    On Error GoTo GestErr

    Application.ScreenUpdating = False
    Set wb = ThisWorkbook

    mesi = Array("Gennaio", "Febbraio", "Marzo", "Aprile", "Maggio", "Giugno", _
                 "Luglio", "Agosto", "Settembre", "Ottobre", "Novembre", "Dicembre")

    meseAttuale = wb.ActiveSheet.Name

    For i = LBound(mesi) To UBound(mesi)
        If StrComp(meseAttuale, mesi(i)) = 0 Then
            meseSuccessivo = mesi((i + 1) Mod 12)
            Exit For
        End If
    Next i

    If meseAttuale = "Dicembre" Then
        appenaCreato = False
        percorsoFile = wb.Path & "\"
        nomeFile = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
        parti = Split(nomeFile, "-")
        nuovoAnno = parti(UBound(parti)) + 1
        nuovoFile = Left(nomeFile, Len(nomeFile) - Len(parti(UBound(parti)))) & nuovoAnno & ".xlsm"

        If MsgBox("Attenzione...stai trasferendo i dati del mese di Dicembre." & String(2, vbCrLf) & _
               "Questi dati verranno cancellati da questo file e trasferiti nel Foglio di Gennaio del file dell'anno successivo a questo." & String(2, vbCrLf) & _
               "Se il file non esiste allora verrà creato identico a questo ma relativo all'anno " & nuovoAnno & " ma ripulito di dati. Se esiste allora i dati verranno accodati a quelli già esistenti.", _
               vbQuestion + vbYesNo, "Sposta dati") = vbNo Then
            errNumber = 1000
            GoTo GestErr
        End If

        If Dir(percorsoFile & nuovoFile) = "" Then
            'il file non esiste allora crealo e aprilo
            appenaCreato = True
            wb.SaveCopyAs (percorsoFile & nuovoFile)
            Set wbNew = Workbooks.Open(percorsoFile & nuovoFile)

            For Each ws In wbNew.Worksheets
                For i = LBound(mesi) To UBound(mesi)
                    If StrComp(ws.Name, mesi(i)) = 0 Then
                        ur = ws.Cells(Rows.Count, "A").End(xlUp).Row
                        If ur > 1 Then
                            On Error Resume Next
                            Set rng = ws.Range("A2:R" & ur).SpecialCells(xlCellTypeConstants) '<--cancello il contenuto solo delle celle senza formule
                            On Error GoTo 0
                            If Not rng Is Nothing Then
                                Application.EnableEvents = False
                                rng.ClearContents
                                Application.EnableEvents = True
                            End If
                        End If
                        Exit For
                    End If
                Next i
            Next ws
        Else
            'file esiste allora aprilo
            Set wbNew = Workbooks.Open(percorsoFile & nuovoFile)
        End If

        Set wsSuccessivo = Nothing
        On Error Resume Next
        Set wsSuccessivo = wbNew.Worksheets(meseSuccessivo)
        On Error GoTo 0
        
        If wsSuccessivo Is Nothing Then
            MsgBox "Il foglio con il nome " & meseSuccessivo & " NON esiste", vbCritical
            errNumber = 1000
            GoTo GestErr
        End If
    Else
        Set wsSuccessivo = Nothing
        On Error Resume Next
        Set wsSuccessivo = wb.Worksheets(meseSuccessivo)
        On Error GoTo 0
        
        If wsSuccessivo Is Nothing Then
            MsgBox "Il foglio con il nome " & meseSuccessivo & " NON esiste", vbCritical
            errNumber = 1000
            GoTo GestErr
        End If
    End If

    Do
        Codice = Application.InputBox("Inserire codice Contatore", "InserireCodice", Type:=1) '<--Type = 1 accetta solo numeri
        If Codice = False Then
            On Error Resume Next
            wbNew.Close False
            On Error GoTo 0
            If appenaCreato Then
                On Error Resume Next
                Kill (percorsoFile & nuovoFile)
                On Error GoTo 0
            End If
            errNumber = 1000
            GoTo GestErr
        End If

        ur = wsSuccessivo.Cells(Rows.Count, "A").End(xlUp).Row

        Set CellaW = wb.Worksheets(meseAttuale).Range("A:A").Find(What:=Codice, LookIn:=xlValues, LookAt:=xlWhole)
        If Not CellaW Is Nothing Then
            firstAddress = CellaW.Address
            Do
                ur = ur + 1

                Application.EnableEvents = False
                With wsSuccessivo
                    .Range("A" & ur & ":F" & ur).Value = wb.Worksheets(meseAttuale).Range("A" & CellaW.Row & ":F" & CellaW.Row).Value
                    .Range("H" & ur & ":K" & ur).Value = wb.Worksheets(meseAttuale).Range("H" & CellaW.Row & ":K" & CellaW.Row).Value
                    .Range("L" & ur & ":M" & ur).Value = wb.Worksheets(meseAttuale).Range("L" & CellaW.Row & ":M" & CellaW.Row).Value
                    .Range("O" & ur & ":R" & ur).Value = wb.Worksheets(meseAttuale).Range("O" & CellaW.Row & ":R" & CellaW.Row).Value

                    If .Cells(ur, "K").Value > 0 And UCase(.Cells(ur, "M").Value) = "SI" Then
                        .Cells(ur, "F").Value = DateAdd("m", 1, .Cells(ur, "F"))
                    End If
                End With

                Set CellaW = wb.Worksheets(meseAttuale).Range("A:A").FindNext(CellaW)
            Loop While Not CellaW Is Nothing And CellaW.Address <> firstAddress
        Else
            MsgBox ("Codice Non Trovato")
        End If

    Loop While MsgBox("Finito!" & String(2, vbCrLf) & "Vuoi inserire un altro codice?", vbYesNo + vbQuestion, "PROSEGUO O ESCO?") = vbYes

    'Sort finale
    With wsSuccessivo
        .Sort.SortFields.Clear
        .Sort.SortFields.Add2 Key:=.Range("B1:B" & ur), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange wsSuccessivo.Range("A1:R" & ur)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        .Select
        .Range("A" & ur + 1).Select
    End With

    Application.EnableEvents = True
    Application.ScreenUpdating = True

safetyExit:
    Set CellaW = Nothing
    Set wbNew = Nothing
    Set wsSuccessivo = Nothing
    Set ws = Nothing
    Set wb = Nothing
    Set rng = Nothing
    Exit Sub

GestErr:
    If errNumber <> 1000 Then
        MsgBox "Attenzione...errore nr: " & Err.Number & " - " & Err.Description, vbCritical, "Gestione errori"
    End If
    Err.Clear
    GoTo safetyExit
End Sub

Tengo a precisare che in tutti gli altri mesi funziona, il problema è solo Dicembre

28/12/2025 alle 21:06 #54184 Score: 0 | Risposta

Frasubb

Partecipante

Karma: 1 pt

trovato il modo, unica cosa che mi trasferisce i dati ma inserendo i dati alla "vecchia maniera" e cioè senza la doppia riga per ogni nominativo (vedi codice VBA qui di seguito)

Private Sub cmdInvia_Click()

    Dim contatore As Long
    Dim rigaDebitore As Variant
    
If cboRicerca <> "" Then
MsgBox "Attenzione ! Record duplice", vbCritical, "Alert"
Call cmdReset_Click
    
    ActiveSheet.Cells(2, 2) = TxtCliente.Text
    Exit Sub
    
End If


  ' Seleziona la cella D2 e copia il suo contenuto (formula)
  Range("D2").Copy

  ' Incolla il contenuto nella cella immediatamente sopra (D2)
  Range("D2").PasteSpecial Paste:=xlPasteFormulas ' Incolla solo la formula
  ' Oppure usa Range("D2").PasteSpecial Paste:=xlPasteAll per incollare tutto (formula+formattazione)
  
  
  ' Rimuove la selezione "formica" (copia attiva)
  Application.CutCopyMode = False
  
  
  Dim ctl As Control

'per ogni controllo nella UserForm
For Each ctl In Me.Controls
    'se il controllo è una TextBox o ComboBox allora...
    If TypeName(ctl) = "TextBox" Or TypeName(ctl) = "ComboBox" Then
        'ad esclusione della ComboBox cboRicerca...
        If ctl.Name <> "cboRicerca" Then
            If Trim(ctl.Value) = "" Then
                MsgBox "Inserire " & ctl.Tag, vbExclamation, "Alert"
                ctl.SetFocus
                Exit Sub
            End If
        End If
    End If
Next ctl


contatore = TxtContatore.Value
    
    Dim arr() As Variant
    Dim r As Long, c As Long, nRows As Long, nCols As Long, k As Long
    Dim temp1 As Variant
    
    nRows = Cells(Rows.Count, "F").End(xlUp).Row
    nCols = 19
    ReDim arr(1 To (nRows + 1), 1 To nCols) As Variant
    
    For r = LBound(arr, 1) To nRows
        For c = LBound(arr, 2) To nCols
            arr(r, c) = Cells(r + 1, c).Value
        Next c
    Next r
    arr(nRows, 1) = contatore 'A
    arr(nRows, 2) = TxtCliente 'B
    arr(nRows, 3) = CDate(Format(TxtDataOper, "dd/mm/yy")) 'C
    arr(nRows, 5) = TxtMandato.Value 'E
    arr(nRows, 6) = CDate(Format(TxtScadPag, "dd/mm/yy")) 'F '<-- da replicare
    arr(nRows, 8) = TxtDebOrigin.Value 'H
    arr(nRows, 9) = TxtAccord.Value 'I
    arr(nRows, 10) = CboNumRate.Value 'J
    arr(nRows, 12) = TxtDaPag.Value 'L

    If ChkSiPag = True Then
        arr(nRows, 13) = "Si" 'M
    Else
        arr(nRows, 13) = "No"
    End If

    If ChkSiContab = True Then
        arr(nRows, 15) = "Si" 'O
    Else
        arr(nRows, 15) = "No"
    End If
 
    If TxtDirLiber = "S" Then
        arr(nRows, 16) = "Si" 'P
    Else
        arr(nRows, 16) = "No"
    End If
    
    arr(nRows, 17) = "No" 'Q
        
    Select Case TxtModalPag 'S
        Case 1
            arr(nRows, 19) = "Bonif"
        Case 2
            arr(nRows, 19) = "B_post"
        Case 3
            arr(nRows, 19) = "QrCode"
        Case Else
            arr(nRows, 19) = "null"
    End Select
    arr(nRows + 1, 6) = CDate(Format(TxtScadPag, "dd/mm/yy")) 'F '<--replicato
        
    'Bubble Sort
    For r = 1 To UBound(arr, 1) - 2 Step 2
        For c = r + 2 To UBound(arr, 1) Step 2
            If UCase(arr(c, 2)) < UCase(arr(r, 2)) Then
                ReDim temp1(1 To 2, 1 To UBound(arr, 2))
                
                For k = 1 To UBound(arr, 2)
                    temp1(1, k) = arr(r, k)
                Next k
                temp1(2, 6) = arr(r + 1, 6)
                
                For k = 1 To UBound(arr, 2)
                    arr(r, k) = arr(c, k)
                Next k
                arr(r + 1, 6) = arr(c + 1, 6)
                
                For k = 1 To UBound(arr, 2)
                    arr(c, k) = temp1(1, k)
                Next k
                arr(c + 1, 6) = temp1(2, 6)
            End If
        Next c
    Next r
    
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    For r = LBound(arr, 1) To UBound(arr, 1)
        Cells(r + 1, "A").Value = arr(r, 1)
        Cells(r + 1, "B").Value = arr(r, 2)
        Cells(r + 1, "C").Value = arr(r, 3)
        Cells(r + 1, "E").Value = arr(r, 5)
        Cells(r + 1, "F").Value = arr(r, 6)
        Cells(r + 1, "H").Value = arr(r, 8)
        Cells(r + 1, "I").Value = arr(r, 9)
        Cells(r + 1, "J").Value = arr(r, 10)
        Cells(r + 1, "L").Value = arr(r, 12)
        Cells(r + 1, "M").Value = arr(r, 13)
        Cells(r + 1, "O").Value = arr(r, 15)
        Cells(r + 1, "P").Value = arr(r, 16)
        Cells(r + 1, "Q").Value = arr(r, 17)
        Cells(r + 1, "S").Value = arr(r, 19)
    Next r
    Application.EnableEvents = True
    Application.ScreenUpdating = True
    
    Call cmdReset_Click
                
    On Error Resume Next
    rigaDebitore = Application.Match(contatore, ActiveSheet.Range("A:A"), 0)
    On Error GoTo 0
    
    If Not IsError(rigaDebitore) Then
        Range("B" & rigaDebitore).Select
    End If

    MsgBox "Inserimento effettuato con successo", vbInformation, "Avviso"

End Sub

01/02/2026 alle 20:30 #54432 Score: 0 | Risposta

Frasubb

Partecipante

Karma: 1 pt

Ciao @alexps81 ti chiedo umilmente scusa se mi rivolgo direttamente a te per chiederti un favore, ma è solo perché mi facesti tu il codice (che allego)

Dopo tutti i cambiamenti migliorativi degli ultimi giorni, non ho pensato che è da aggiornare anche il codice che trasferisce record da un mese all'altro cioè, a differenza di prima, adesso nel trasferimento vanno inclusi Numero Tel e codice fiscale che fanno parte della riga aggiuntiva di ogni nominativo.

Cortesemente me lo potresti aggiornare in considerazione di ciò ?

Ripeto, ti chiedo scusa se mi permetto di inviarti una richiesta così diretta, ma è solo perché essendo ad un nuovo mese e dovendo trasferire i nominativi, non ho il codice aggiornato.

Ti ringrazio e scusami ancora

Private Sub CmdTransfert_Click()

Dim MIoMese
Dim MesePrecedente
Dim DataMia
Dim Codice
Dim CellaW
MIoMese = ActiveSheet.Name
DataMia = CDate("01 " & MIoMese & " 2000")
DataMia = Format(DataMia - 2, "Mmmm")
Dim m_stAddress
Dim MioRangeFiltro
MesePrecedente = UCase(Left(DataMia, 1)) & Right(DataMia, Len(DataMia) - 1)
On Error GoTo GestErr
Do
    With Sheets(MesePrecedente).Range("A:A")
    
On Error GoTo 0

    Codice = InputBox("Inserire codice Contatore", "InserireCodice")
    If Codice = "" Then Exit Sub
        Set CellaW = .Find(What:=Codice)
        If Not CellaW Is Nothing Then
            m_stAddress = CellaW.Address
            Do
                'Sheets(MesePrecedente).Activate
                'CellaW.Select
                'CellaW.Resize(1, 17).Select
                'Sheets(MIoMese).Activate
                'Sheets(MIoMese).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 17).Select
                Application.EnableEvents = False '<-aggiunta
                CellaW.Resize(1, 17).Copy Destination:=Sheets(MIoMese).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
                If Application.Evaluate(Sheets(MIoMese).Cells(Cells(Rows.Count, 1).End(xlUp).Row, "K").Address) > 1 Then 'test se il valore in K è maggiore di 1 '<-aggiunta
        Sheets(MIoMese).Cells(Cells(Rows.Count, 1).End(xlUp).Row, "F") = DateAdd("m", 1, Sheets(MIoMese).Cells(Cells(Rows.Count, 1).End(xlUp).Row, "F")) '<-aggiunta
    End If                        '<-aggiunta
    Application.EnableEvents = True '<-aggiunta
                Set CellaW = .FindNext(CellaW)
            Loop While Not CellaW Is Nothing And CellaW.Address <> m_stAddress
        Else
            MsgBox ("Codice Non Trovato")
        End If
    End With
        
    With Sheets(MIoMese)
        .Sort.SortFields.Clear
        Set MioRangeFiltro = .Range(Sheets(MIoMese).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0), "Q1")
        .Sort.SortFields.Add2 Key:=Range("B:B") _
        , SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange MioRangeFiltro
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
Loop While MsgBox("Vuoi inserire un altro codice?", vbYesNo + vbQuestion, "PROSEGUO O ESCO?") = vbYes
Exit Sub

ActiveSheet.Range("A2").CurrentRegion.Sort Key1:=ActiveSheet.Range("B2"), Order1:=xlAscending, Header:=xlYes

GestErr:
MsgBox "il foglio con il nome " & MesePrecedente & " NON esiste", vbOKOnly + vbCritical
End Sub

Autore

Articoli

Stai vedendo 6 articoli - dal 26 a 31 (di 31 totali)

← 1 2