Problema su attività automatiche macro

Hai un problema con Excel?

Nuova discussione

Problema su attività automatiche macro
di simodome91 (utente non iscritto) data: 29/12/2015 23:00:25
Buona sera a tutti;
Avrei due problemi che non riesco a risolvere, spero qualcuno possa darmi una mano perchè non ho l'esperienza per farcela.

Le macro si trovano tutte e 2 in un foglio e una si attiva con doppio click, invece l'altra cambiando il valore di una cella...

La prima macro nasce in questo forum e svolge il suo compito:
1. Doppio click su cella; se non c'è crea il foglio prendendo il nome della cella seleziona altrimenti lo apre.
Problema: su qualsiasi cella io faccio doppio click lui prova ad eseguire la macro dandomi un errore.

La seconda macro è molto incasinata perchè sono riuscito a farla iniziando a leggere un libro sull'argomento e cercando soluzioni su google:
2. Sostanzialmente ordina un elenco, elimina righe vuote, aggiunge righe vuote in base alla cella a cui andrà in contro.
Problema: Funziona con un pulsante ma non così;

Spero possiate aiutarmi...

Vi ringrazio in anticipo,

Simone

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Doppio click
On Error GoTo errore 'Se va in error attiva routine "errore"
If Not Application.Intersect(Target, Range("E12:E500")) Is Nothing Then 'Scelta del range doppio click
 Workbooks("InfoGara.xlsx").Activate 'Attiva file "InfoGara"
 Sheets(Target.Text).Select ' se il foglio esiste lo seleziona altrimeni va a "errrore"
 Exit Sub 'Esci dalla macro
errore: 'Specifica routine "errore" in caso di error
  If Target.Text = "" Then Exit Sub 'Se la cella cliccata è vuota esci dalla macro
  End If 'Fine funzione If
Application.DisplayAlerts = False ' Evita gli alert, hai dei nomi nel foglio base e verranno duplicati
  Sheets("Base").Copy After:=Sheets(Sheets.Count) ' Copia "base" e lo posiziona in fondo
  Sheets(Sheets.Count).Name = Target.Text ' Rinomina il foglio copiato
  Application.DisplayAlerts = True ' Ripristina gli alert
End Sub 'Fine Macro

Private Sub Worksheet_Change(ByVal Target As Range) 'Cambio cella
Dim KeyCells As Range 'Variabile keycells
Set KeyCells = Range("c14:c500") 'Imposto range

Application.ScreenUpdating = False 'Toglie visione macro

'1. Settaggio formati (per impedire differenze di formato sugli spostamenti delle prossime macro)

    Dim wk2 As Workbook
    Dim sh2 As Worksheet
    Dim lng2 As Long
    Set wk2 = ThisWorkbook
    Set sh2 = wk2.Worksheets("calendario") 'Variabili varie (da sistemare, si ripetono 3 volte!)*
  
    With sh2 'Ciclo for per settaggio formato
      For lng2 = .Range("c" & .Rows.Count).End(xlUp).Row To 16 Step -1
      If .Cells(lng2, 3) <> .Cells(lng2 - 1, 3) And .Cells(lng2, 3) <> "" And .Cells(lng2, 3).Offset(0, 1) = "" Then
        Rows("14:14").Select
        Selection.Copy
        .Cells(lng2, 3).EntireRow.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
      End If
      Next
    End With
   
    Set sh2 = Nothing 'Da capire
    Set wk2 = Nothing 'Da capire

'2. Elimina righe vuote
    ThisWorkbook.Sheets("calendario").Select
    Range("c14:c500").SpecialCells(xlCellTypeBlanks).EntireRow.Delete 'Seleziona range

'3. Ordina per data
    Dim WS As Worksheet
    Set WS = ThisWorkbook.Worksheets("calendario")
    Dim R As Range
    Set R = WS.Range("c14:n500") 'Variabili
    
    With WS.Sort 'Celle che si ordineranno (Insieme in base alla prima ("c"))
      .SortFields.Clear
        .SortFields.Add Key:=Range("c14:c500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("d14:d500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("e14:e500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("f14:f500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("g14:g500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("h14:h500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("i14:i500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("j14:j500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("k14:k500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("l14:l500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("m14:m500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SortFields.Add Key:=Range("n14:n500"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
      .SetRange R
      .Header = xlNo
      .MatchCase = False
      .Orientation = xlTopToBottom
      .Apply
    End With
    
'4.Inserimento righe vuote e sistemazione (estetica del foglio)
    Dim wk As Workbook
    Dim sh As Worksheet
    Dim lng As Long
    Set wk = ThisWorkbook
    Set sh = wk.Worksheets("calendario") 'Variabili (*da sistemare)
    
  
    With sh
      For lng = .Range("c" & .Rows.Count).End(xlUp).Row To 16 Step -1
      If .Cells(lng, 3) <> .Cells(lng - 1, 3) And .Cells(lng, 3) <> "" And .Cells(lng, 3).Offset(0, 1) <> "" Then
        .Cells(lng, 3).EntireRow.Insert Shift:=xlDown
                .Cells(lng, 3).EntireRow.Insert Shift:=xlDown
                
      Else
                
      If .Cells(lng, 3) <> .Cells(lng - 1, 3) And .Cells(lng, 3) <> "" And .Cells(lng, 3).Offset(0, 1) = "" Then
        .Cells(lng, 3).EntireRow.Insert Shift:=xlDown
        .Cells(lng, 3).Offset(2, 0).EntireRow.Delete
        .Cells(lng, 3).Offset(2, 0).EntireRow.Delete
        .Cells(lng, 3).EntireRow.Copy
        .Cells(lng, 3).Offset(2, 0).EntireRow.Select
        Selection.Insert Shift:=xlDown
      End If
      End If
      Next
    End With
   
    Set sh = Nothing
    Set wk = Nothing 'Non so
   
'5.Settaggio formato mesi come prima
    Dim wk1 As Workbook
    Dim sh1 As Worksheet
    Dim lng1 As Long
    Set wk1 = ThisWorkbook
    Set sh1 = wk1.Worksheets("calendario") '*Le solite variabili
    
    With sh1
      For lng1 = .Range("c" & .Rows.Count).End(xlUp).Row To 16 Step -1
      If .Cells(lng1, 3) <> .Cells(lng1 - 1, 3) And .Cells(lng1, 3) <> "" And .Cells(lng1, 3).Offset(0, 1) = "" Then
        Rows("12:12").Select
        Selection.Copy
        .Cells(lng1, 3).EntireRow.Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=False, Transpose:=False
      End If
      Next
    End With
   
    Set sh1 = Nothing
    Set wk1 = Nothing
    
'6.Selezione per eliminare il tratteggio del tagli sullo schermo e la selezione cella
    Cells(600, 1).EntireRow.Copy
    Range("a1").Select
    
Application.ScreenUpdating = True 'Riavvia la visione

End Sub

di simodome91 (utente non iscritto) data: 30/12/2015 00:04:27
Allego file di prova per una maggiore comprensione;

Sul file c'è il pulsante con la macro che non funziona con l'evento cambia cella;
Per quanto riguarda il doppio click l'ho reso funzionante sul file che vi allego creando un foglio "base", cosi da poterlo provare voi stessi;
In qualsiasi cella faccio doppio click la macro si attiva.

Ancora grazie,

Simone
di patel data: 30/12/2015 09:09:07
nel file di prova la macro è diversa da quella che hai inserito nel primo messaggio
di simodome91 (utente non iscritto) data: 30/12/2015 09:22:13
Ho inserito la seconda macro su un pulsante (per mostrare il suo funzionamento con pulsante) e modificato la prima macro (doppio click) in modo che funzioni sullo stesso file (funzionava nello stesso modo ma aggiungeva il foglio su un altra cartella)...scusatemi per la confusione...
Simone

di patel data: 30/12/2015 14:02:10
prova così

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean) 'Doppio click
On Error GoTo errore 'Se va in error attiva routine "errore"
If Not Application.Intersect(Target, Range("D12:D500")) Is Nothing And Target <> "" Then 'Scelta del range doppio click
   Sheets(Target.Text).Select ' se il foglio esiste lo seleziona altrimeni va a "errrore"
   Exit Sub 'Esci dalla macro
errore:    'Specifica routine "errore" in caso di error
   Application.DisplayAlerts = False ' Evita gli alert, hai dei nomi nel foglio base e verranno duplicati
   Sheets("Base").Copy After:=Sheets(Sheets.Count) ' Copia "base" e lo posiziona in fondo
   Sheets(Sheets.Count).Name = Target.Text ' Rinomina il foglio copiato
   Application.DisplayAlerts = True ' Ripristina gli alert
End If
End Sub 'Fine Macro

di patel data: 30/12/2015 14:04:03
per il resto non ho capito
Problema: Funziona con un pulsante ma non così;
così come ?
di simodome91 (utente non iscritto) data: 30/12/2015 15:15:53
ok il doppio click adesso funziona perfettamente, la macro che è sul pulsante funziona perfettamente; ho provato a renderla automatica al cambio del valore cella di un range (la macro sul primo messaggio) e non funziona; mi da errori e crasha...la situazione è strana poichè sul pulsante funziona... intanto grazie mille per la risoluzione del doppio click.

Simone
di patel data: 30/12/2015 15:20:59
non puoi spiegarti meglio ? quale cella ? quale foglio ? quale valore ?
di simodome91 (utente non iscritto) data: 30/12/2015 16:09:34
Ok mi rispiego da capo togliendo la doppio click che è risolta..grazie per la pazienza;

Sull'allegato c'è un pulsante che mette in funzione una macro (il pulsante l'ho utilizzato solo nella creazione della macro ma risolto il problema lo elimino)...io vorrei che la macro si avviasse cambiando una data che si trova nel range ("c14:c500") ....come soluzione ho optato per introdurre all'inizio della macro:

Private Sub Worksheet_Change(ByVal Target As Range) 'Cambio cella
Dim KeyCells As Range 'Variabile keycells
Set KeyCells = Range("c14:c500") 'Imposto range

ma la macro non funziona più.

Per ulteriori spiegazioni chiedi pure

Simone

di patel data: 30/12/2015 17:11:25
prova così

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Column = 3 Then Pulsante1_Click 
End Sub

di simodome91 (utente non iscritto) data: 30/12/2015 17:27:40
Perfetto grazie 1000!
Non avevo pensato ad una soluzione di questo tipo...eppure logicamente era da provare...

Pongi pongi poropò...

Grazie 1000 Patel, sei il numero 1.

Buona serata e buon anno a tutti :)

Simone
di patel data: 30/12/2015 18:45:29
approfitto dell'assenza dei numeri 1 per sentirmi numero 1 anch'io
Buon anno a tutti

Vuoi Approfondire?