Forum - VBA Συγχώνευση κελιών

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

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

- - [VBA] Συγχώνευση κελιών (https://www.ms-office.gr/forum/excel-erotiseis-apantiseis/1784-sygxoneysi-kelion.html)

Συγχώνευση κελιών

Καλησπέρα σε όλους.
Παρακαλώ εάν μπορεί να δημιουργηθεί ενας κωδικας με τα παρακάτω στοιχεία.
Σε ένα φύλλο εργασίας ,στη περοχή AQ5:BW500, όπου βρίσκει κενό κελί και το ακριβώς κάτω από αυτό να έχει το γράμμα m,
τότε να γίνεται συγχώνευση των δύο κελιών και να παίρνει το όνομα m, στη συνέχεια να γινεται στοίχιση οριζόντια(κέντρο), κατακόρυφα (κέντρο) το μέγεθος του m να γίνεται 18, η γραμματοσειρά να είναι arial greek, έντονη γραφή.
Ευχαριστώ εκ των προτέρων.

Καλημέρα σε όλους!
Μάκη, για την περιοχή AQ4:BW500 του επιλεγμένου φύλλου, βάλε τον παρακάτω κώδικα σε μια κοινή λειτουργική μονάδα και δοκίμασε:

Κώδικας:

Option Explicit
 

Sub MergeFoundCells()

    Dim SearchString

    Dim CurrAddress As String

    Dim MainRange As Range

    Dim rng As Range

    Dim AddrArray As Variant

    Dim i As Long

    Set MainRange = Range("AQ4:BW500")

    SearchString = "m"

    Set rng = MainRange.Find(SearchString, LookIn:=xlValues)

    If Not rng Is Nothing Then

        CurrAddress = rng.Address

    Else

        Exit Sub

    End If

    Do

        If Not rng.MergeCells Then

            If Trim(rng.Offset(-1)) = vbNullString Then

                AddrArray = AddrArray & ";" & rng.Address

            End If

        End If

        Set rng = MainRange.FindNext(rng)

    Loop While Not rng Is Nothing And rng.Address <> CurrAddress

    AddrArray = Split(AddrArray, ";")

    For i = 1 To UBound(AddrArray)

        Set rng = Range(Range(AddrArray(i)), Range(AddrArray(i)).Offset(-1))

        rng.Merge

        rng.HorizontalAlignment = xlCenter

        rng.VerticalAlignment = xlCenter

        With rng.Font

            .Name = "Arial"

            .Size = 18

            .Bold = True

        End With

    Next

End Sub

Φιλικά

Τάσος

Τάσο σε ευχαριστώ πολύ.σου εύχομε καλή Ανασταση

Να είσαι καλά Μάκη!

Καλό Πάσχα και σε σένα!

Κάτι μου ξέφυγε στον κώδικα γι αυτό σε παρακαλώ άλλαξε στον κώδικα σου το η γραμμή:

For i = 1 To UBound(AddrArray) -1
με

For i = 1 To UBound(AddrArray)

Τάσος

Εκανα δοκιμή Τάσο στο αρχειο που σου επισυνάπτω(test 3) και δεν μου δουλευει,εαν εχεις χρόνο ρίξε μια ματιά,Ευχαριστώ.

Μάκη, στο νέο σου παράδειγμα ( σε αντίθεση με αρχικό σου ) τα κελιά που φαίνονται κενά στην πραγματικότητα δεν είναι κενά με αποτέλεσμα να εμφανίζεται το γνωστό προειδοποιητικό μήνυμα.

Προφανώς εισάγεις τα δεδομένα αυτά από κάποια εξωτερική πηγή.

Τροποποίησε λοιπόν τον κώδικα σου έτσι:

Κώδικας:

Option Explicit
 

Sub MergeFoundCells()

    Dim SearchString

    Dim CurrAddress As String

    Dim MainRange As Range

    Dim rng As Range

    Dim AddrArray As Variant

    Dim i As Long

    Set MainRange = Range("AP2:CB500")

    SearchString = "m"

    Set rng = MainRange.Find(SearchString, LookIn:=xlValues)

    If Not rng Is Nothing Then

        CurrAddress = rng.Address

    Else

        Exit Sub

    End If

    Do

        If Not rng.MergeCells Then

            If Trim(rng.Offset(-1)) = vbNullString Then

                AddrArray = AddrArray & ";" & rng.Address

            End If

        End If

        Set rng = MainRange.FindNext(rng)

    Loop While Not rng Is Nothing And rng.Address <> CurrAddress

    AddrArray = Split(AddrArray, ";")

    Application.ScreenUpdating = False

    For i = 1 To UBound(AddrArray)

    Range(AddrArray(i)).Offset(-1).ClearContents

        Set rng = Range(Range(AddrArray(i)), Range(AddrArray(i)).Offset(-1))

        rng.Merge

        rng.HorizontalAlignment = xlCenter

        rng.VerticalAlignment = xlCenter

        With rng.Font

            .Name = "Arial"

            .Size = 18

            .Bold = True

        End With

    Next

End Sub

Τάσος

Τάσο σε ευχαριστώ και πάλι,ο κωδικας τώρα ειναι όπως τον θέλω,σου εύχομαι καλό Πάσχα με υγεία..