Copia Dati su altro foglio in base al valore della Data

[Zagor57]

Buongiorno a tutto il Forum
avrei bisogno del vostro aiuto
Ho un DataBase il cui contenuto è un elenco di Date nella colonna "B" e a seguire sulla riga altri dati fino alla colonna "G"
La macro che vorrei fare e di: Trasferire i dati della riga dalla colonna "B " alla colonna "G" in base al valore della Data (mese), nel rispettivo foglio con il nome del mese

Es: la data 15/01/22 =(Gennaio) deve copiare i dati nel foglio (Gen ) la data 25/02/22 (Febbraio ) Copia i dati nel foglio ( Feb) e cosi via
e possibile un aiuto
Grazie

[Anthony47]

Trovo che spezzettare il database sia una operazioni autolesionistica, quindi spero in un tuo ravvedimento e ti aiuto proprio controvoglia...
Ad esempio questa macro:

Codice: Seleziona tutto

Sub Zagor()
Dim I As Long, deSh As String, NextR As Long
'
Sheets("FoglioDati").Select             '<<< Il foglio di partenza
'
For I = 1 To Cells(Rows.Count, "B").End(xlUp).Row
    If IsDate(Cells(I, "B").Value) Then
        deSh = Format(Cells(I, "B"), "mmmm")
        NextR = Sheets(deSh).Cells(Rows.Count, "B").End(xlUp).Row + 1       '**
        Cells(I, 2).Resize(1, 6).Copy Sheets(deSh).Cells(NextR, "B")      '**
    End If
Next I
MsgBox ("Spezzatino completato...")
End Sub

Il codice va copiato in un Modulo standard del tuo Vba. I fogli mensili devono gia' esistere; l'istruzione marcata <<< va adattata

Ho interpretato che anche nei fogli mensili le informazioni vanno scritte da colonna B; se non e' così allora devi modificare quei "B" nelle due righe marcate **

Fai sapere...

[Zagor57]

Prima di ogni cosa……….. Grazie
Sicuramente mi sono espresso molto male , non voglio spezzettare il DataBase ….

La cartella di lavoro altro non è che una prima nota cassa/Banche
Che è composta da 12 fogli uno per mese :Gen—Feb-Mar-eccc fino a Dic
Dato che siamo alla fine dell’anno e devo copiarmi l’intero anno e riprogrammarlo per il prossimo anno avendo una continuità di tutti i valori ,poiché nel mese di Dic (Dicembre) ci sono delle scadenze da riportare nei mesi successivi esattamente a (Gen-Feb-Mar-Apr) vorrei aggiungere alla macro che mi cancella i vecchi dati e mi riporta i valori al nuovo anno che: ( deve prendersi i valori delle righe che hanno come valore al mese successivo a dicembre dell’anno in corso e trasferirli nel mese di appartenenza es: la scadenza con data 15/01/22 a Gen (Gennaio) ---la scadenza con data 15/02/22 a Feb(Febbraio) ----- la scadenza con data 15/03/22 nel mese di Mar( Marzo)

Spero di essere stato più chiaro

Ancora grazie per il tuo aiuto

[Zagor57]

Ps: il codice che mi hai dato inserito nel contesto della macro non funziona mi copia solo i dati di Dicembre sempre nello stesso foglio gli altri (Gen-Feb-Mar-Apr) non vengono copiati

allego l'Intera Macro

Codice: Seleziona tutto

Sub CancellaDati()
'
' CancellaDati
'
Application.ScreenUpdating = False
'
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>   copia l'intero anno in archivio
'
 If UCase(Sheets("MENU").Range("L2")) <> "PROCEDI" Then '<<<<<<<<<Condizione di conferma se salvare o non salvare
     ActiveSheet.Unprotect
     MsgBox ("ATTENZIONE......Dati non Caricati Inserire <<< PROCEDI >>> Nella Cella di colore Rosso")
   
     Range("L2").Interior.ColorIndex = 3 '..........la cella si colora di  rosso
     Range("L2").Select
     Range("B12").Select
    Selection.Copy
    Range("M2").Select
    ActiveSheet.Paste
    Range("L2").Select
     MsgBox ("INSERISCI ( PROCEDI ) NELLA CELLA ROSSA E ...... RIPETI OPERAZIONE")
    Exit Sub
     End If
     'MsgBox ("RIPETI OPERAZIONE")
    '....
    '
    'Range("AZ6").Interior.ColorIndex = 2 '..........la cella si colora di  bianco
    '...
     'Call myLink(myName)
    On Error GoTo 0
    RISPO = MsgBox("L'Anno in Corso verrà Archiviato e i dati verranno cancellati!" & vbCrLf & " " & vbCrLf & "                    Si Prega scegliere " & vbCrLf & " " & vbCrLf & "Si per continuare ,  No per interrompere senza copiare e cancellare", vbYesNo + vbExclamation)
    If RISPO <> vbYes Then
        MsgBox ("Il file non e' stato Copiato e azzerato...")
        Exit Sub
    End If
    '.......
    Range("L2").Interior.ColorIndex = 2 '..........la cella si colora di  bianco
        'UserForm1.Show vbModeless
        'DoEvents
    MsgBox ("        Inizio copia Integrale del File.....Premere OK        ")
    Range("a1").FormulaR1C1 = "=today()"
   
nome = "D:\excel\Archivio Prima nota cassa ditta SRL\Prima Nota Cassa srl Anno " & Format([A1], "dd-mm-yyyy") & ".xlsm"

'MsgBox (nome)
     ActiveWorkbook.SaveCopyAs Filename:=nome
      MsgBox ("         Inizio Preparazione Anno Nuovo.....Premere OK           ")
      Range("L2").Select
    Selection.ClearContents
    Range("M2").Select
    Selection.ClearContents
'
'>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>Fine copia in archivio
'
'>>>>>>>>>>>>>>>>> Cambio numero dell'anno
'
Sheets("liste").Select
    ActiveSheet.Unprotect
    Range("H2").Select
    Selection.Copy
    Range("I2").Select
    ActiveSheet.Paste
    Range("H2").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    Range("K2").Select
    Selection.Copy
    Range("H2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
'
'>>>>>>>>>>>>>>>>>>>Riporto a NUOVO i saldi di fine anno
'
    Sheets("Dic").Select
    ActiveSheet.Unprotect
    Range("K4").Select
    Selection.Copy
    Sheets("liste").Select
    Application.CutCopyMode = False
    ActiveSheet.Unprotect
    Range("H6").Select
    Sheets("Dic").Select
    Selection.Copy
    Sheets("liste").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Dic").Select
    Range("N6").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("J6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Dic").Select
    Range("R4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("L6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Dic").Select
    Range("U4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("N6").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Sheets("Dic").Select
    Range("AB4").Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("liste").Select
    Range("H9").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    Application.CutCopyMode = False
    ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
        False
    Sheets("Dic").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Gen").Select
    Range("C7").Select
    '
    'Fine copia saldi
    '
    '>>>>>>>>>>>>>>>>>>>>>>>>>>> Cancella i dati dei mesi Gen-Feb-Mar-Apr
     ActiveSheet.Unprotect
    Sheets("Feb").Select
    ActiveSheet.Unprotect
    Sheets("Mar").Select
    ActiveSheet.Unprotect
    Sheets("Apr").Select
    ActiveSheet.Unprotect
    Sheets("Mag").Select
    ActiveSheet.Unprotect
    Sheets("Giu").Select
    ActiveSheet.Unprotect
    Sheets("Lug").Select
    ActiveSheet.Unprotect
    Sheets("Ago").Select
    ActiveSheet.Unprotect
    Sheets("Set").Select
    ActiveSheet.Unprotect
    Sheets("Ott").Select
    ActiveSheet.Unprotect
    Sheets("Nov").Select
    ActiveSheet.Unprotect
    Sheets("Dic").Select
    ActiveSheet.Unprotect
    Sheets(Array("Gen", "Feb", "Mar", "Apr")).Select
    Sheets("Gen").Activate
    Range("B7:D275").Select
    Selection.ClearContents
    Range("G7:G275").Select
    Selection.ClearContents
    Sheets("Gen").Activate
    Range("B7").Select
    '
    '<<<<<<<<< Riporta le scadenze da Dic , nei mesi Gen,Feb,Mar,Apr
    '
    Dim I As Long, deSh As String, NextR As Long
Sheets("Dic").Select '<<<<<<<<<<< Il foglio di partenza
For I = 1 To Cells(Rows.Count, "B").End(xlUp).Row
    If IsDate(Cells(I, "B").Value) Then
        deSh = Format(Cells(I, "B"), "mmm")
        NextR = Sheets(deSh).Cells(Rows.Count, "B").End(xlUp).Row + 1       '**
        Cells(I, 2).Resize(1, 6).Copy Sheets(deSh).Cells(NextR, "B")      '**
    End If
Next I
     '
     '<<<<<<<<<<<<<<<<<<<<<<<<<<<<Fine Copia scadenze
     '
     '>>>>>>>>>>>>>>>>>>>>>>>>>>> Cancella i dati dei mesi Mag-Giu.Lug-Ago-Set-Ott-Nov-Dic
     '
    Sheets(Array("Mag", "Giu", "Lug", "Ago", "Set", "Ott", "Nov", _
        "Dic")).Select
    Sheets("Mag").Activate
    Range("B7:D275").Select
    Selection.ClearContents
    Range("G7:G275").Select
    Selection.ClearContents
    Sheets("Gen").Activate
    Range("B7").Select
    '
    '<<<<<<<<<<<<<<<<<<<< Inizio Protezione fogli
    '
    Sheets("Gen").Select
    Range("C7").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Feb").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Mar").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Apr").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Mag").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Giu").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Lug").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Ago").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Set").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Ott").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Nov").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Dic").Select
    ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
    Sheets("Gen").Select
    Range("C7").Select
    '
    '<<<<<<<<<<<<<<<<< Fine protezione fogli
    '
    MsgBox "Salvataggio Dati Andato a buon Fine ..Buon Inizio Anno"
   
  'Unload UserForm1
    Exit Sub
    Application.ScreenUpdating = True
    '
    'ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
   ' ActiveWorkbook.Save
    '
   
End Sub






[Anthony47]

Lieto di leggere che non volevi spezzettare il database.

La macro e' così elementare che non sono riuscito ad associare il problema che segnali a qualche situazione strana.
Modifica il codice aggiungendo uno Stop prima e uno dopo il presunto smazzamento, piu' un "debug.print", come segue:

Codice: Seleziona tutto

Sheets("Dic").Select '<<<<<<<<<<< Il foglio di partenza
Stop
For I = 1 To Cells(Rows.Count, "B").End(xlUp).Row
    If IsDate(Cells(I, "B").Value) Then
        deSh = Format(Cells(I, "B"), "mmmm")
        NextR = Sheets(deSh).Cells(Rows.Count, "B").End(xlUp).Row + 1       '**
        Debug.Print I, Cells(I, "B"), deSh, NextR
        Cells(I, 2).Resize(1, 6).Copy Sheets(deSh).Cells(NextR, "B")      '**
    End If
Next I
Stop


Quando la macro si ferma al primo Stop controlla il contenuto di "dic" per vedere se le righe sono tutte con una data valida.
Quando si ferma sul secondo Stop controlla quali righe siano state smazzate e quali no; poi apri la finesta Immediata del vba, copia tutto quello che ci trovi dentro e pubblicalo nel tuo prossimo messaggio, insieme ad eventuali constatazioni del foglio di partenza (dic) e di come e' andato lo smazzamento.
Per aprire la finesta Immediata: dal vba, premi Contr-g, oppure usa Menu /Visualizza /Finestra Immediata

Ciao

[Zagor57]

Anthony Trovato l'errore----- mio
non so per quale motivo nella riga 856 c'erano dei dati e la cancellazione avviene fino alla riga 275 e naturalmente i dati venivano accodati dalla riga 856 in poi
è tutto OK ...............solo una piccola correzione possiamo non far ricopiare tutti i dati di Dicembre ?
mi sarebbe sufficiente che copia i dati di gennaio febbraio marzo aprile
Grazie

[Anthony47]

Ok
Per saltare dicembre possiamo aggiungere un livello di If:

Codice: Seleziona tutto

    If IsDate(Cells(I, "B").Value) Then
        deSh = Format(Cells(I, "B"), "mmm")
        If Ucase(deSh) <> "DIC" Then
            NextR = Sheets(deSh).Cells(Rows.Count, "B").End(xlUp).Row + 1       '**
            Debug.Print I, Cells(I, "B"), deSh, NextR
            Cells(I, 2).Resize(1, 6).Copy Sheets(deSh).Cells(NextR, "B")        '**
        End If
    End If


Ciao

[Zagor57]

Anthony
Grazie tutto perfetto come lo desideravo
sei un grande

GRAZIEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEEE