Forum - Excel07 Δημιουργία κουμπιού

Forum (https://www.ms-office.gr/forum/)

- Excel - Ερωτήσεις / Απαντήσεις (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/)

- - [Excel07] Δημιουργία κουμπιού (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/4939-dimioyrgia-koympioi.html)

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

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

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

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

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

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

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

Καλησπέρα σας παιδιά. Πιστεύω να είστε καλά.
Συνάντησα ένα θεματάκι με τον πίνακα στον υπολογιστή που πήγα να το δουλέψω.
στο κομμάτι παρακάτω.
Όταν άνοιξα τον πίνακα, με το που έκανα κλικ στα φύλλα, πέταξε 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.
Θα γίνει καλά γιατρέ μου;;;

Καλησπέρα

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

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

Θα πρέπει να τσεκάρεις όσες φαίνονται στο συνημμένο και να ξετσεκάρεις όσες είναι 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

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

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

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

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