[Excel07] Δημιουργία κουμπιού

[stam75]

Πολύ ωραία σας ευχαριστώ για μια ακόμη φορά παιδιά!

[kapetang]

Σταμάτη να είσαι καλά και ελπίζω τώρα να τελειώσαμε....

Στο προηγούμενο μήνυμά μου κατά λάθος επισύναψα μια παλιότερη έκδοση του αρχείου.

Την αντικατέστησα.

[Spirosgr]

Και στο post 41, να αλλάξεις στην γραμμή:
If Not Nme.Name Like "!*Print_Area*" Then
την ακολουθία !* σε *! ...

[stam75]

Έγινε παιδιά θα τα τσεκάρω αυτά που είπατε!
Η αλήθεια είναι πως ναι πρέπει να σταματήσουμε. Ολοκληρώθηκε αυτό που ζητούσα, έγιναν βελτιώσεις, διορθώσεις, γενικά πιστεύω πως το επίπεδο είναι πολύ παραπάνω από αυτο που ζητούσα και ανταποκριθήκατε άμεσα σε κάθε βήμα για την λύση του. Να είστε καλά, σας υπέρ ευχαριστώ!

[stam75]

Καλησπέρα!
Έχω κάνει μερικές μικροαλλαγές στην εμφάνιση και κάποιες προσθήκες και είπα να σας δείξω όπως είναι τώρα
Φαντάζομαι πως όταν τελειώσει όλο το στήσιμο θα ανέβει γιατί ενδιαφέρει κάποια άτομα. Όπως επίσης μπορεί κάποιος που θα το δουλέψει να το βελτιώσει!

[stam75]

Καλησπέρα σας παιδιά. Πιστεύω να είστε καλά.
Συνάντησα ένα θεματάκι με τον πίνακα στον υπολογιστή που πήγα να το δουλέψω.
στο κομμάτι παρακάτω.
Όταν άνοιξα τον πίνακα, με το που έκανα κλικ στα φύλλα, πέταξε error, έκανα debug, κιτρίνισε η σειρά που έχω με Magenta και μπλε η σειρά που έχω το κόκκινο.

Private Sub Lst_Sh_Click()
    Dim Nme As Name, rngTest As Range, LO As ListObject, sh As Worksheet, i As Long
    Me.Lst_NmRng.Clear
    Set shSel = Worksheets(Me.Lst_Sh.Value)
    ReDim x(1, 1000) As String
    On Error Resume Next
    For Each Nme In ThisWorkbook.Names
        Set rngTest = Range(Nme.Name)
        If Err = 0 Then
            If Not Nme.Name Like "*!Print_Area*" Then
                If Nme.RefersTo Like "*" & Me.Lst_Sh.Value & "*" Then
                    x(0, i) = Nme.Name:
                    x(1, i) = Replace(Replace(Replace(Replace(Nme.RefersTo, "$", ""), "'", ""), Me.Lst_Sh.Value & "!", ""), "=", "")
                    i = i + 1
                End If
            End If
        Else
            Err.Clear
        End If
    Next Nme
    On Error GoTo 0
    Set sh = Worksheets(Me.Lst_Sh.Value)
    For Each LO In sh.ListObjects
        x(0, i) = LO.Name: x(1, i) = Replace(LO.Range.Address, "$", "")
        Me.Lst_NmRng.AddItem LO.Name
        i = i + 1
    Next
    ReDim Preserve x(1, i) As String
    Me.Lst_NmRng.Column = x
    If i = 0 Then shSel.Activate
End Sub

Σε ίδιο λειτουργικό, ίδια office.
Θα γίνει καλά γιατρέ μου;;;

[kapetang]

Καλησπέρα

Σταμάτη, ο κώδικας που επισυνάπτεις, στον υπολογιστή μου, λειτουργεί κανονικά.

Θα πρότεινα να ελέγξεις τις αναφορές.

Θα πρέπει να τσεκάρεις όσες φαίνονται στο συνημμένο και να ξετσεκάρεις όσες είναι MISSING.

Δοκίμασε και τον κώδικα (έκανα κάποιες αλλαγές) :

Option Explicit
Dim shSel As Worksheet

Private Sub Lst_NmRng_Click()
    shSel.Activate
    Application.Goto Range(Me.Lst_NmRng.Value), False
End Sub

Private Sub Lst_Sh_Click()
    Dim Nme As Name, rngTest As Range, LO As ListObject, i As Long, x() As String
    
    Me.Lst_NmRng.Clear
    Set shSel = Worksheets(Me.Lst_Sh.Value)
    ReDim x(1, 1000) As String

    On Error Resume Next
    For Each Nme In ThisWorkbook.Names
        Set rngTest = Range(Nme.Name)
        If Err = 0 Then
            If Not Nme.Name Like "*!Print_Area*" Then
                If Nme.RefersTo Like "*" & Me.Lst_Sh.Value & "*" Then
                    x(0, i) = Nme.Name
                    x(1, i) = Replace(Replace(Replace(Replace(Nme.RefersTo, "$", ""), "'", ""), _
                                Me.Lst_Sh.Value & "!", ""), "=", "")
                    i = i + 1
                End If
            End If
        Else
            Err.Clear
        End If
    Next Nme
    On Error GoTo 0

    For Each LO In shSel.ListObjects
        x(0, i) = LO.Name: x(1, i) = Replace(LO.Range.Address, "$", "")
        i = i + 1
    Next
    If i = 0 Then
        shSel.Activate
    Else
        ReDim Preserve x(1, i) As String
        Me.Lst_NmRng.Column = x
    End If
    
End Sub

Private Sub UserForm_Initialize()
    Dim Wsh As Worksheet
    For Each Wsh In ThisWorkbook.Sheets
        Me.Lst_Sh.AddItem Wsh.Name
    Next Wsh
End Sub

Καλή τύχη ...............

[stam75]

Γιώργο μόλις έκανα τις αλλαγές. Σε ευχαριστώ πολύ για μια ακόμη φορά.

[stam75]

Καλημέρα σας!
Γιώργο οι αλλαγές που έκανες τελευταία στον κώδικα λειτουργούν άψογα. Πλέον λειτουργεί και στον άλλον υπολογιστή. Σε ευχαριστώ πολύ!

[kapetang]

Να είσαι καλά Σταμάτη και καλή συνέχεια.