Risultati da 1 a 1 di 1

Discussione: pop-up shape alla selezione cella e creazione di tabelle usando caselle di testo



  1. #1
    L'avatar di ggratis
    Clicca e Apri
    Data Registrazione
    Sep 2015
    Località
    Lecce - Pisa
    Età
    45
    Messaggi
    737
    Versione Office
    Excel 2010
    Likes ricevuti
    257
    Likes dati
    215

    pop-up shape alla selezione cella e creazione di tabelle usando caselle di testo

    Vi condivido questo mio lavoretto. Nei fogli di calcolo con situazioni complesse, che richiedo la visualizzazione di tabelle o immagini può essere utile...

    in un modulo standard:
    Codice: 
    Option Explicit
    Sub tabella(nome As String, nr As Long, nc As Long)
    'Dim nome As String
    Dim i As Long, j As Long, ind As Long
    Dim x As Long, y As Long
    'Dim nc As Long, nr As Long
    Dim c As Long, r As Long, d As Long, h As Long, dc As Long, dr As Long
    Dim lista() As Variant
       
    Dim shp As Shape
    
    
    For Each shp In ActiveSheet.Shapes
        If shp.Name = nome Then
        MsgBox "Nel foglio è già presente una tabella denominata " & nome & " pertanto non è stata creata"
        Exit Sub
            End If
    Next
            'nome = "Tac" 'nome della tabella
            
            x = 48 'ascissa del vertice da cui si comincia a creare la tabella rispetto all'origine in alto a sinistra
            y = 15 'ordinata del vertice da cui si comincia a creare la lista
            c = x 'spigolo in alto a sinistra
            r = y 'spigolo in alto a sinistra
            d = 48 'spigolo in basso a destra-larghezza della cella
            h = 15 'spigolo in basso a destra-altezza della cella
            dc = 48 'passo tra gli spigoli omologhi-sulla collonna
            dr = 15 'passo tra gli spigoli omologhi-sulla riga
            ind = 0
            'nc = 2 ' numero colonne
            'nr = 2 'numero righe
            ReDim lista(1 To nc * nr) As Variant
            For i = 1 To nr
            For j = 1 To nc
            ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, c, r, d, h).Select
            Selection.ShapeRange.Name = nome & "_" & i & "," & j
            With ActiveSheet.Shapes.Range(Array(nome & "_" & i & "," & j))
                    With .TextFrame2
                        .MarginLeft = 0
                        .MarginRight = 0
                        .MarginTop = 0
                        .MarginBottom = 0
                        .VerticalAnchor = msoAnchorMiddle
                        .HorizontalAnchor = msoAnchorCenter
                        .TextRange.Characters.Text = "0"
                        .TextRange.Characters(1, 1).ParagraphFormat.FirstLineIndent = 0
                                With .TextRange.Characters(1, 1).Font
                                    .NameComplexScript = "+mn-cs"
                                    .NameFarEast = "+mn-ea"
                                    .Fill.Visible = msoTrue
                                    .Fill.ForeColor.ObjectThemeColor = msoThemeColorDark1
                                    .Fill.ForeColor.TintAndShade = 0
                                    .Fill.ForeColor.Brightness = 0
                                    .Fill.Transparency = 0
                                    .Fill.Solid
                                    .Size = 11
                                    .Name = "+mn-lt"
                                End With
                        End With
                    With .Fill
                        .Visible = msoTrue
                        .ForeColor.ObjectThemeColor = msoThemeColorBackground1
                        .ForeColor.TintAndShade = 0
                        .ForeColor.Brightness = -0.0500000007
                        .Transparency = 0
                        .Solid
                    End With
                    With .Line
                        .Visible = msoTrue
                        .ForeColor.ObjectThemeColor = msoThemeColorText1
                        .ForeColor.TintAndShade = 0
                        .ForeColor.Brightness = 0
                        .Transparency = 0
                    End With
            End With
            c = c + dc
            '******************************creo la lista di celle da selezionare per preare il gruppo******************************
            ind = j + nc * (i - 1)
            lista(ind) = nome & "_" & i & "," & j
            '***********************************************************************************************************************
        Next j
        c = x
        r = r + dr
        Next i
        ActiveSheet.Shapes.Range(lista).Select
        Selection.ShapeRange.Group.Select
        Selection.Name = nome
    End Sub
    Sub assegna(cella As Variant, valore As String)
    ActiveSheet.Shapes.Range(Array(cella)).TextFrame2.TextRange.Characters.Text = valore
    End Sub
    Sub mostra(nome As String)
    ActiveSheet.Shapes.Range(nome).Visible = True
    End Sub
    Sub nascondi(nome As String)
    ActiveSheet.Shapes.Range(nome).Visible = False
    End Sub
    Sub imgZoomIn(img As Variant)
    ActiveSheet.Shapes.Range(Array(img)).ScaleHeight 1, msoTrue, msoScaleFromTopLeft
    End Sub
    Sub imgZoomOut(img As Variant)
    ActiveSheet.Shapes.Range(Array(img)).ScaleHeight 0.25, msoTrue, msoScaleFromTopLeft
    End Sub
    
    
    Sub creaTabelle()
    Call tabella("tab1", 2, 6)
    Call tabella("tab2", 6, 2)
    Call tabella("Tac", 6, 6)
    Call assegna("Tac_1,2", "ok")
    End Sub
    nel foglio:
    Codice: 
    
    
    
    
    Private Sub Worksheet_SelectionChange(ByVal Target As Range)
         If Not Application.Intersect([B10], Range(Target.Address)) Is Nothing Then
            Call mostra("Tac")
            Call mostra("tab1")
        Else
            Call nascondi("Tac")
            Call nascondi("tab1")
        End If
         
         If Not Application.Intersect([B11], Range(Target.Address)) Is Nothing Then
            Call mostra("Immagine 1")
            Call mostra("tab2")
        Else
            Call nascondi("Immagine 1")
            Call nascondi("tab2")
        End If
        
         If Not Application.Intersect([B12], Range(Target.Address)) Is Nothing Then
            Call imgZoomIn("Picture 2")
        Else
            Call imgZoomOut("Picture 2")
        End If
    End Sub
    File Allegati File Allegati

  2. I seguenti 2 utenti hanno dato un "Like" a ggratis per questo post:


Discussioni Simili

  1. [Risolto] Testo interno di una "Shape" preso da una cella
    Di atievoli nel forum Domande su Excel VBA e MACRO
    Risposte: 2
    Ultimo Messaggio: 11/02/17, 10:51
  2. foglio con menù a tendina, caselle di selezione e conteggio dati
    Di M_Druido nel forum Domande su Excel in generale
    Risposte: 1
    Ultimo Messaggio: 31/01/17, 11:59
  3. [Risolto] Funzione ripetuta su Foglio1 usando tabelle fisse del foglio2
    Di EnzoNN nel forum Domande su Excel in generale
    Risposte: 2
    Ultimo Messaggio: 27/11/16, 12:05
  4. [Risolto] Testo che si Autoridimensiona alla cella
    Di claudiopsr nel forum Domande sul Microsoft Word
    Risposte: 5
    Ultimo Messaggio: 15/11/16, 11:00
  5. Nascondere zona esterna alla selezione
    Di zio_tom nel forum Domande su Excel VBA e MACRO
    Risposte: 16
    Ultimo Messaggio: 28/11/15, 13:50

Tag per Questa Discussione

Permessi di Scrittura

  • Tu non puoi inviare nuove discussioni
  • Tu non puoi inviare risposte
  • Tu non puoi inviare allegati
  • Tu non puoi modificare i tuoi messaggi
  •