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

[misirlis]

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

[Tasos]

Καλημέρα σε όλους!
Μάκη, για την περιοχή 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

Φιλικά

Τάσος

[misirlis]

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

[Tasos]

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

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

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

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

For i = 1 To UBound(AddrArray)

Τάσος

[misirlis]

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

[Tasos]

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

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

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

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

Τάσος

[misirlis]

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