preleva e crea nuovo foglio

[raimea]

ciao
tramite una macro vorrei prelevare delle righe
e creare un nuovo foglio dandole il nome con la data scritta in B3

1_dal fgl generale al nuovo foglio va riportato pari-pari
l'ntestazione compresi i pulsanti quindi un copia-incolla
del range A1:M7

poi:
2_ prelevare da col A:M
le righe con la data in col D pari a quella indicata in B3 e B4
incollare il contenuto nel nuovo foglio partendo da cella A8

se nelle celle B3_B4 metto la stessa data,
indica di prelevare solo quel giorno

vi allego un file

https://www.dropbox.com/s/1sqxmf9m7wiofn6/crea_foglio16.rar?dl=0

grazie
ciao

[Anthony47]

Puoi ottenere facilmente quanti chiedi con una macro autoregistrata usando il seguente processo:
-sul foglio "Generale" imposti il filtro automatico alla colonna D, da D7 fino alla fine
-selezioni Foglio1
-avvii la registrazione di una nuova macro
-selezioni il foglio "Generale"
-duplichi il foglio: tasto dx sul tab col nome del foglio; scegli Sposta o copia; spunta Crea una copia; scegli "Prima del foglio... " -- "Foglio1"; conferma con Ok.
-rinomina il foglio appena creato come PIPPO
-imposta il filtro su colonna D affinche' visualizzi le date "prima di" e come data scrivi quella impostata in B3, oppure le date "dopo" e come data scrivi quella in B4. Su XL2016 (non ho sottomano XL2010) la procedura e': clicca sul filtro, scegli Filtri per data /Filtro personalizzato; la prima scelta sara' "E' prima di", metti la data; spunta OR e come seconda scelta "E' dopo", metti la data; completi con Ok
-le date così visualizzate sono quelle da eliminare: seleziona manualmente le righe visibili ed Eliminale
-infine elimina il filtro e visualizzerai le righe residue, che dovrebbero corrispondere a quanto richiesto
-interrompi la registrazione macro

Il codice cosi' ottenuto ha bisogno di qualche editing per funzionare; visualizza il codice della macro e poi:
a) tutte le righe che contengono ActiveWindow.LargeScroll oppure ActiveWindow.SmallScroll possono essere eliminate
b) trova la riga che assegna il nome PIPPO al foglio creato, e sostituisci la riga con

Codice: Seleziona tutto

ActiveSheet.Name = Format(Range("B3").Value, "dd-mm-yyyy")

c) trova le righe che applicano il filtro automatico e sosttituisci con

Codice: Seleziona tutto

    ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1, Criteria1:= _
        "<" & Format(Range("B3").Value, "yyyy-mm-dd"), Operator:=xlOr, Criteria2:=">=" & Format(1 + Range("B4").Value, "yyyy-mm-dd")


d) trova la riga che seleziona le righe excel da cancellare (a me e' uscito Rows("8:5574").Select) e sostituisci con

Codice: Seleziona tutto

Range("A" & Range("A8:A7000").SpecialCells(xlCellTypeVisible)(1).Row).Resize(7000).EntireRow.Select

e) trova la riga che elimina il filtro (l'istruzione che termina con .AutoFilter Field:=1) e sostituisci con

Codice: Seleziona tutto

    ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1

f) infine, subito prima di End Sub aggiungi

Codice: Seleziona tutto

    Range("B8").Value = 1
    Range("A8").Value = 1

g) potrebbe anche essere utile inserire in testa, subito dopo la riga che seleziona il foglio "Generale"

Codice: Seleziona tutto

If Range("B3") = "" Or Range("B4") = "" Then Beep: Exit Sub

In questo modo la macro non si esegue se B3 o B4 non sono compilati

Per informazioni e suggerimenti su come registrare o editare una macro: viewtopic.php?f=26&t=103893

Prova e fai sapere

[raimea]

ciao
ho eseguito il compito ma il risultato ottenuto non e' correto
ovviamente ho sbagliato qualche passaggio.

ho messa date:
dal 11.7.20
al 13.7.20
ma per poter vedere il gg 11 E 13 ho dovuto impostare la data 14.7.20
altrimenti il gg 13.7.20 non me lo faceva vedere

comunque questa la macro ottenuta con le correzioni indicate:

Codice: Seleziona tutto

Sub filtrodate()
'
    Sheets("generale").Select
    If Range("B3") = "" Or Range("B4") = "" Then Beep: Exit Sub
   
    Sheets("generale").Copy Before:=Sheets(1)
    Sheets("generale (2)").Select
   
   ' Sheets("generale (2)").Name = "pippo"
    ActiveSheet.Name = Format(Range("B3").Value, "dd-mm-yyyy")
   
    Range("D8").Select
   
   'ActiveSheet.Range("$D$7:$D$5567").AutoFilter Field:=1, Criteria1:= _
        "<11/07/2020", Operator:=xlOr, Criteria2:=">14/07/2020"
       
      ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1, Criteria1:= _
        "<" & Format(Range("B3").Value, "yyyy-mm-dd"), Operator:=xlOr, Criteria2:=">=" & Format(1 + Range("B4").Value, "yyyy-mm-dd")
   
   '   Rows("8:5615").Select
   ' Selection.Delete Shift:=xlUp
    Range("A" & Range("A8:A7000").SpecialCells(xlCellTypeVisible)(1).Row).Resize(7000).EntireRow.Select
   
    ActiveWindow.ScrollRow = 5594
    ActiveWindow.ScrollRow = 5524
    ActiveWindow.ScrollRow = 5394
    ActiveWindow.ScrollRow = 5241
    ActiveWindow.ScrollRow = 4710
    ActiveWindow.ScrollRow = 4427
    ActiveWindow.ScrollRow = 4204
    ActiveWindow.ScrollRow = 3815
    ActiveWindow.ScrollRow = 3367
    ActiveWindow.ScrollRow = 3060
    ActiveWindow.ScrollRow = 2695
   
   ' ActiveSheet.Range("$D$7:$D$2886").AutoFilter Field:=1
    ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1
   
    ActiveWindow.ScrollRow = 2890
    ActiveWindow.ScrollRow = 2879
    ActiveWindow.ScrollRow = 2867
    ActiveWindow.ScrollRow = 2809
    ActiveWindow.ScrollRow = 2564
    ActiveWindow.ScrollRow = 2202
    ActiveWindow.ScrollRow = 1793
    ActiveWindow.ScrollRow = 1537
    ActiveWindow.ScrollRow = 1303
    ActiveWindow.ScrollRow = 1128
    ActiveWindow.ScrollRow = 1012
    ActiveWindow.ScrollRow = 953
    ActiveWindow.ScrollRow = 696
    ActiveWindow.ScrollRow = 661
    ActiveWindow.ScrollRow = 638
    ActiveWindow.ScrollRow = 591
    ActiveWindow.ScrollRow = 521
    ActiveWindow.ScrollRow = 498
    ActiveWindow.ScrollRow = 451
    ActiveWindow.ScrollRow = 428
    ActiveWindow.ScrollRow = 405
    ActiveWindow.ScrollRow = 393
    ActiveWindow.ScrollRow = 381
    ActiveWindow.ScrollRow = 358
    ActiveWindow.ScrollRow = 346
    ActiveWindow.ScrollRow = 323
    ActiveWindow.ScrollRow = 311
    ActiveWindow.ScrollRow = 300
    ActiveWindow.ScrollRow = 288
    ActiveWindow.ScrollRow = 276
    ActiveWindow.ScrollRow = 265
    ActiveWindow.ScrollRow = 241
    ActiveWindow.ScrollRow = 218
    ActiveWindow.ScrollRow = 195
    ActiveWindow.ScrollRow = 171
    ActiveWindow.ScrollRow = 125
    ActiveWindow.ScrollRow = 78
    ActiveWindow.ScrollRow = 8
 
    Range("D6").Select
   
    Range("B8").Value = 1
    Range("A8").Value = 1
   
End Sub


nel nuovo foglio creato mi trovo le righe che sarebbero da eliminare !

ciao

[Anthony47]

ho messo le date:
dal 11.7.20
al 13.7.20
ma per poter vedere il gg 11 E 13 ho dovuto impostare la data 14.7.20

Questo non dovrebbe essere necessario dopo la modifica della macro, perche' il criterio di filtro viene impostato con Format(1 + Range("B4").Value, "yyyy-mm-dd")

comunque questa la macro ottenuta con le correzioni indicate [. . . .] [ma] nel nuovo foglio creato mi trovo le righe che sarebbero da eliminare !

Questo succede perche' hai eliminato l'istruzione che cancella le righe (Selection.Delete Shift:=xlUp); la sequenza giusta:

Codice: Seleziona tutto

   '   Rows("8:5615").Select                         'Eliminata, ok
    Range("A" & Range("A8:A7000").SpecialCells(xlCellTypeVisible)(1).Row).Resize(7000).EntireRow.Select
    Selection.Delete Shift:=xlUp       

E tutte tutte quelle righe ActiveWindow.ScrollRow possono essere eliminate

Ciao

[raimea]

ciao
bene sono sulla buona strada
questa la macro attuale che svolge il compito:

Codice: Seleziona tutto

Sub filtrodate()
'
    Sheets("generale").Select
    If Range("B3") = "" Or Range("B4") = "" Then Beep: Exit Sub
   
    Sheets("generale").Copy Before:=Sheets(1)
    Sheets("generale (2)").Select
   
   ' Sheets("generale (2)").Name = "pippo"
    ActiveSheet.Name = Format(Range("B3").Value, "dd-mm-yyyy")
   
    Range("D8").Select
   
   'ActiveSheet.Range("$D$7:$D$5567").AutoFilter Field:=1, Criteria1:= _
        "<11/07/2020", Operator:=xlOr, Criteria2:=">14/07/2020"
       
      ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1, Criteria1:= _
        "<" & Format(Range("B3").Value, "yyyy-mm-dd"), Operator:=xlOr, Criteria2:=">=" & Format(1 + Range("B4").Value, "yyyy-mm-dd")
   
   '   Rows("8:5615").Select
    Range("A" & Range("A8:A7000").SpecialCells(xlCellTypeVisible)(1).Row).Resize(7000).EntireRow.Select
    Selection.Delete Shift:=xlUp

   
   ' ActiveSheet.Range("$D$7:$D$2886").AutoFilter Field:=1
    ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1
 
 
    Range("D6").Select
   
    Range("B8").Value = 1
    Range("A8").Value = 1
   
End Sub


ora, nel nuovo foglio
sotto all ultima data indicata riporta dei caratteri
come eliminarli ?



2 se premo una 2da volta con la stessa data in B3 mi da errore ma non va bene
perche' potrei aver cambiato la data in B4
quindi il folgio va creato ugualmente magari mettendo _2 _3



ciao

[Anthony47]

Sempre con registra macro si puo' andare in fondo ai dati che cominciano in D7, poi spostarsi sulla riga +1 e colonna -1, quindi estendere la selezione e infine eliminare le righe.
Gli aggiustamenti del caso portano a questo codice, che va inserito tra l'istruzione che scrive 1 in A8 e la riga End Sub:

Codice: Seleziona tutto

    Range("D7").End(xlDown).Select
    Selection.Offset(1, -1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.EntireRow.Delete


Quanto alla numerazione del foglio, sostituisci la riga ActiveSheet.Name = Format(Range("B3").Value, "dd-mm-yyyy") con Call riNomina
Aggiungi poi questa nuova Sub:

Codice: Seleziona tutto

Sub riNomina()
Dim ckNome As String
On Error Resume Next
For I = 1 To 100
    ckNome = ""
    ckNome = Sheets(Format(Range("B3").Value, "dd-mm-yyyy_") & I).Name
    If ckNome = "" Then ActiveSheet.Name = Format(Range("B3").Value, "dd-mm-yyyy_") & I: Exit For
Next I
On Error GoTo 0
End Sub

Ciao

[raimea]

ciao
e' tutto ok
grazie mille

questa la macro finale:

Codice: Seleziona tutto

Sub filtrodate()

    Sheets("generale").Select
    If Range("B3") = "" Or Range("B4") = "" Then Beep: Exit Sub
   
    Sheets("generale").Copy Before:=Sheets(1)
    Sheets("generale (2)").Select
   
    'ActiveSheet.Name = Format(Range("B3").Value, "dd-mm-yyyy")
    Call riNomina
   
   
    Range("D8").Select
   
      ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1, Criteria1:= _
        "<" & Format(Range("B3").Value, "yyyy-mm-dd"), Operator:=xlOr, Criteria2:=">=" & Format(1 + Range("B4").Value, "yyyy-mm-dd")
   
   
    Range("A" & Range("A8:A7000").SpecialCells(xlCellTypeVisible)(1).Row).Resize(7000).EntireRow.Select
    Selection.Delete Shift:=xlUp

   
    ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1
 
 
    Range("D6").Select
   
    Range("B8").Value = 1
    Range("A8").Value = 1
   
'----cancello contenuto colonne ABC in fondo----------------
    Range("D7").End(xlDown).Select
    Selection.Offset(1, -1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.EntireRow.Delete
   
End Sub

[raimea]

ciao
facendo delle prove sul file che contiene circa 3000 righe
ho incappato in un caso che manda in bug la macro

nel caso che in B3 o B4
inserisco una data che non c'e' nel fgl generale
vorrei poter gestire questo caso con un msg box


2_ al nuovo fgl creato volevo dare un colore diverso da verde
alla linguetta del nuovo foglio creato

ho usato il registratore di macro ottenendo:

Codice: Seleziona tutto

Sub aaa()
'
' aaa Macro
'

'--coloro la linguetta fgl---------------------------------
    Sheets("25-07-2020_1").Select
    With ActiveWorkbook.Sheets("25-07-2020_1").Tab
        .Color = 6684927
        .TintAndShade = 0
    End With
End Sub


che ovviamente funziona SOLO quando creo fgl .._1

ho provato in vari modi a modificarla ma non sono mai riuscito
a farla funzionare x fogli diversi da ..._1


ciao

[Anthony47]

Per il colore della linguetta puoi lavorare sull'ActiveSheet; quindi:

Codice: Seleziona tutto

    Sheets("generale").Copy Before:=Sheets(1)
''    Sheets("generale (2)").Select                     '<<< ELIMINARE
    'ActiveSheet.Name = Format(Range("B3").Value, "dd-mm-yyyy")
    Call riNomina
'COLORA LA LINGUETTA:
    With ActiveSheet.Tab
        .Color = 6684927
        .TintAndShade = 0
    End With

    Range("D8").Select

Ti ho evidenziato anche una riga che e' meglio cancellare

Per quanto riguarda i casi in cui non vengono restituite righe, ho modificato la parte finale per farla fluire senza errori e per segnalare con msgbox la situazione di tabella vuota:

Codice: Seleziona tutto

'----cancello contenuto colonne ABC in fondo----------------
    Cells(Rows.Count, "D").End(xlUp).Select         'MODIF
    Selection.Offset(1, -1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.EntireRow.Delete
If Selection.Cells(1, 1).Row = 8 Then               'AGG
    MsgBox ("L'estrazione non ha restituito righe di dati")
'
'Altre azioni?
'
End If
End Sub

Nello stesso ciclo If /EndIf puoi inserire ulteriori azioni; ad esempio la rimozione del foglio se e' l'azione piu' appropriata.

Ciao

[raimea]

ciao
ok x il colore delle linguette

nel caso una o entrambe le date B3 o B4
non ci sono vorrei che il foglio NON venga creato

con il registratore ho regist l'eliminaz del foglio
e inserito il comando dove richiesto

ma essendoci altri comandi sotto non so come farli "saltare " nel caso cancello il foglio

questa l attuale macro:

Codice: Seleziona tutto

Sub filtrodate()
'------------------------------
' luglio 20
' dal sito pc-facile
' http://www.pc-facile.com/forum/viewtopic.php?f=26&t=111455&p=654619&sid=f77129b67549097541dfaf0f27cdc0d6#p654619
'-------------------------------

    Sheets("generale").Select
    If Range("B3") = "" Or Range("B4") = "" Then Beep: Exit Sub
   
    Sheets("generale").Copy Before:=Sheets(1)
       
    Call riNomina
   
    '----COLORA LA LINGUETTA:---------
    With ActiveSheet.Tab
        .Color = 6684927
        .TintAndShade = 0
    End With
   
    Range("D8").Select
   
      ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1, Criteria1:= _
        "<" & Format(Range("B3").Value, "yyyy-mm-dd"), Operator:=xlOr, Criteria2:=">=" & Format(1 + Range("B4").Value, "yyyy-mm-dd")
   
   
    Range("A" & Range("A8:A7000").SpecialCells(xlCellTypeVisible)(1).Row).Resize(7000).EntireRow.Select
    Selection.Delete Shift:=xlUp

   
    ActiveSheet.Range("$D$7:$D$7000").AutoFilter Field:=1
 
 
    Range("D6").Select
   
    Range("B8").Value = 1
    Range("A8").Value = 1
   
 '----cancello contenuto colonne ABC in fondo----------------
    Cells(Rows.Count, "D").End(xlUp).Select
   
    Selection.Offset(1, -1).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.EntireRow.Delete
   
'-----verifico se le date ci sono---------------------------------------
If Selection.Cells(1, 1).Row = 8 Then               'AGG
    MsgBox ("L'estrazione non ha restituito righe di dati")
'
'Altre azioni?
'
'
'

ActiveWindow.SelectedSheets.Delete    '<<< agg io x eliminare fgl

End If
   
   
'---cancello nel nuovo foglio---------
    Range("A2").Select
    Selection.ClearContents
    ActiveSheet.Shapes.Range(Array("Picture 16")).Select
    Selection.Cut
'----tolgo parte sx nel nuovo fgl -----------------------------
    ActiveSheet.Shapes.Range(Array("Rounded Rectangle 9")).Select
    Range("S3").Select
    ActiveSheet.Shapes.Range(Array("Rounded Rectangle 9")).Select
    Selection.Cut
    Range("Q4:Z4").Select
    Selection.AutoFill Destination:=Range("Q4:Z50"), Type:=xlFillDefault
    Range("Q4:Z50").Select
    ActiveSheet.Shapes.Range(Array("Right Arrow 13")).Select
    Selection.Cut
    Selection.ClearComments
  '----metto davanti fgl generale-------------
    Sheets("generale").Select
    Sheets("generale").Move Before:=Sheets(1)
   

End Sub

ciao

[Anthony47]

nel caso una o entrambe le date B3 o B4 non ci sono vorrei che il foglio NON venga creato

Questo e' gia' fatto tramite la riga If Range("B3") = "" Or Range("B4") = "" Then Beep: Exit Sub, in testa alla macro.

Per eliminare il foglio privo di dati e smetterla lì potresti usare questa soluzione:

Codice: Seleziona tutto

    If Selection.Cells(1, 1).Row = 8 Then               'AGG
        MsgBox ("L'estrazione non ha restituito righe di dati")
        Application.DisplayAlerts = False
        ActiveSheet.Delete
        Application.DisplayAlerts = True
        Sheets("generale").Select
        '
        'Altre ulteriori azioni?
        '
        Exit Sub
    End If
'La macro continua
'...


Ciao

[raimea]

ciao

qui mi sono espresso male io !

nel caso una o entrambe le date B3 o B4
non ci sono vorrei che il foglio NON venga creato

avrei dovuto scrivere:
nel caso una o entrambe le date B3 o B4 non ci sono >> in colonna D <<
vorrei che il foglio NON venga creato

attualmente

Codice: Seleziona tutto

    Sheets("generale").Select
    If Range("B3") = "" Or Range("B4") = "" Then Beep: Exit Sub

controlla che le celle B3 e B4 non siano vuote
e anche questo controllo va bene.

ora con l'ultima modifica:

considerando la data 16.3.20 che in col D NON c'e'

se metto
in B3 dal 16-3-20
in B4 al 17-5-20 (presente in Col D)
la macro crea il foglio mentre vorrei NON lo creasse

se metto
in B3 dal 16-3-20
in B4 al 16-3-20
la macro non crea il foglio ed e' correto.

se metto
in B3 dal 15-3-20 (presente in col D)
in B4 al 16-3-20
la macro crea il foglio, ovviamente riportando solo le righe del 15.3.20
mentre vorrei che anche in questo caso non venga creato

ciao

[Anthony47]

Si puo' fare nella macro, ma il mio suggerimento e' che sottoponi a convalida le celle B3-B4
Seleziona B3:B4, avvia la convalida dati; sul tab Impostazioni scegli Consenti=Personalizzato; come formula inserisci

Codice: Seleziona tutto

=SOMMA(SE(INT($D$8:$D$5000)=$B3;1;0))

Sul tab Messaggio di errore inserisci, come "Messaggio di errore" il testo Data non presente; riprova

Completa la convalida

Se non funziona correttamente riapri la convalida impostata e scrivi la formula usando Contr-Maiusc-Enter

In questo modo dovresti non riuscire a inserire date che non siano in elenco.

Fai sapere...

[raimea]

ciao

ottimo
e' tutto ok

ho inserito il convalida come indicato
e non ho dovuto inserire >>> Contr-Maiusc-Enter

sembrava un "lavoretto" semplice ma ci sono sempre in tutti i flie, le eccezioni da gestire.

grazie la pazienza

ciao

[raimea]

Ciao
c'e un bug saltuario....

nel senso che generalmente succede all aperture del file
la prima volta che cerco di inserire le date ( presenti in col D ) nelle celle B3 o B4

poi dopo un po di tentativi con errore pur usando stesse date
"riparte" l 'errore non lo da piu

esce l avviso di data non presente:


nelle celle B3 B4 ho messo la formula convalida:

Codice: Seleziona tutto

=SOMMA(SE(INT($D$8:$D$10000)=$B4;1;0))

ho prevato anche usare con Contr-Maiusc-Enter

Ciao

[Anthony47]

Allora modifica la formula di convalida in

Codice: Seleziona tutto

=SOMMA(SE(INT($D$8:$D$5000)=$B4;1;0))>0

Analoga modifica va fatta in B3

Ciao

[raimea]

ciao

ho inserito la nuovo formula

Codice: Seleziona tutto

=SOMMA(SE(INT($D$8:$D$5000)=$B4;1;0))>0

ma il problema rimane uguale

lo risolvo solo se:
all apertura del file rientro in convalida di entrambe le celle B3 B4
e do di nuovo un invio alla formula gia' inserita
allora dopo, fa il controllo correttamente.

mi viene un dubbio :
se alla fine della formula uso Contr-Maiusc-Enter
non dovrebbe mettere una parentesi graffa ?
cosa che non mette

perche usando Contr-Maiusc-Enter
alla fine della formula nella sintassi non cambianulla

ciao

[Anthony47]

Ho il ricordo che nella convalida le formule che fanno riferimento a matrici sono automaticamente interpretate come formule a matrici; e comunque le parentesi graffe si vedono solo nella barra della formula.

Comunque ho visto anche io il buffo comportamento; incaponendomi a rimanere sulla Convalida personalizzata ho modificato le formule per B3 e B4 rispettivamente in :

Codice: Seleziona tutto

=CONTA.PIÙ.SE(D7:D5000;">="&B3;D7:D5000;"<"&(B3+1))>0

Codice: Seleziona tutto

=CONTA.PIÙ.SE(D7:D5000;">="&B4;D7:D5000;"<"&(B4+1))>0

A me funziona, se a te non funziona allora buttiamo la Convalida e facciamo via macro.

Ciao

[raimea]

ciao
funziona

con le nuave formule in convalida
ho fatto alcuni test di chiudere e riaprire il file

e riconosce analizza corrtettamente le date inserite

faro' ulteriori test in questi giorni

grazie mille

ciao