Çözüldü Formülle Veri Aktarılan Birleştirilmiş Hücrenin Satır Yüksekliğinin Makro ile Otomatik Ayarlanması

[malitogan]

Merhabalar.
Değerli uzman arkadaşlar, sorunumu daha önce “Hücreye Girilen Metin İçin Otomatik Satır Yüksekliği Ayarlama” başlıklı, 24.04.2020 tarihli konunun altına yazmıştım. Konu biraz eski olunca cevabım dikkat çekmemiş ve fark edilmemiş olabilir. Bu yüzden özür dileyerek yeni bir konu başlığı altında sormak istedim.
Makro ile satır yüksekliğini otomatik ayarlama konusunda 2 problemim var. Bu konu başlığı adı altında sunulan çözüm (Korhan AYHAN Bey’in örnek dosyada yer alan cevabı, “https://www.excel.web.tr/threads/huecreye-girilen-metin-icin-otomatik-satir-yueksekligi-ayarlama.187394/post-1036868”) tam aradığım gibi. Ancak bunu benim dosyama uyarlayamadım. (Bulduğum benzer başka cevapları da uyarlamayı bir türlü beceremedim.) Satır yüksekliği ayarlamasının, formülle veri aktarılan birkaç sayfada ve birleştirilmiş hücrede olması gerekiyor.
1’inci sorunum; Örnek dosyada görüleceği üzere “Bilgi” sayfasındaki “İş konusu” ile “Yüklenici Firma” hücrelerindeki verilerin “Kapak”, “HİK Teklif” ve “HİK Tutanak” sayfalarındaki ilgili hücrelere aktarıldığında aktarılan veriler hücreye sığmadığında satır yüksekliğinin otomatik olarak metne göre artması. Bilgi sayfasındaki veri silindiğinde satır yüksekliğinin eski yüksekliğine geri gelmesi.
Yine “Bilgi” sayfasında “Diğer Kesinti Nedeni” hücresindeki verinin “Rapor” sayfasında işaretli hücreye aktarıldığında satır yüksekliğinin otomatik ayarlanması.
2’nci sorunum ise, “KT Tutanak” sayfasında 10 adet boş satır var. Buralara manuel olarak veri girişi yapılıyor. 11,25 olan satır yüksekliğinin, satıra sığmayan veri girildiğinde otomatik olarak artması, hücre içerisindeki veri silindiğinde satır yüksekliğinin yine 11,25 olması.
Not: Veri bulunan ve veri aktarılan sayfalar normalde şifre korumalı olarak kullanılıyor. Sayfa koruması açılmış olarak yükledim.
Bu konularda yardımcı olursanız memnun olurum.

 

[Korhan Ayhan]

Merhaba,

BİLGİ isimli sayfanızın kod bölümüne uygulayıp deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim S4 As Worksheet, S5 As Worksheet, S6 As Worksheet
    Dim X_Width As Variant, X_Height As Variant
    Dim My_Data As Variant, X_Row As Integer
    Dim X As Integer, Y As Integer, X_Factor As Double
    Dim WS As Worksheet, Change_Row_Height As Variant
   
    If Intersect(Target, Range("K8:AI9,K52:AI52")) Is Nothing Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set S1 = Sheets("Bilgi")
    Set S2 = Sheets("Kapak")
    Set S3 = Sheets("HİK Teklif")
    Set S4 = Sheets("HİK Tutanak")
    Set S5 = Sheets("Rapor")
   
    S2.Unprotect "12345"
    S3.Unprotect "12345"
    S4.Unprotect "12345"
    S5.Unprotect "12345"
   
    On Error Resume Next
    Sheets("Test").Delete
    On Error GoTo 0
   
    Sheets.Add
    Set S6 = ActiveSheet
    S6.Name = "Test"
   
    ReDim X_Zoom(2)
   
    For Each WS In Sheets(Array("Kapak", "HİK Teklif", "HİK Tutanak"))
        WS.Activate
        X_Zoom(X) = ActiveWindow.Zoom
        X = X + 1
    Next
   
    Target.Parent.Select
   
    Select Case Target.Cells(1, 1).Address(0, 0)
        Case "K8"
            X_Width = Array(S2.Range("R6:AW6").Columns.Width, _
                             S3.Range("S4:AX4").Columns.Width, _
                             S4.Range("S4:AX4").Columns.Width)
                       
            Change_Row_Height = Array(S2.Rows(6), S3.Rows(4), S4.Rows(4))
           
            ReDim X_Height(2)
           
            For X = LBound(X_Width) To UBound(X_Width)
                X_Factor = 5.3
                X_Row = 2
                With S6
                    .Cells.Delete
                    .Cells.Font.Size = S1.Range("A1").Font.Size
                    .Range("A1") = Target.Text
                    .Range("A:A").WrapText = True
                    .Range("A1").VerticalAlignment = xlJustify
                     X_Factor = ((1 + (X_Zoom(X) / 1000 - 0.02)) * X_Factor)
                    .Range("A1").ColumnWidth = X_Width(X) / X_Factor
                    .Range("A1").EntireRow.AutoFit
               
                    My_Data = Split(.Range("A1"), Chr(10))
               
                    For Y = 0 To UBound(My_Data)
                        .Cells(X_Row, 1) = My_Data(Y)
                        X_Height(X) = X_Height(X) + IIf(.Cells(X_Row, 1).RowHeight < 12, 12, .Cells(X_Row, 1).RowHeight)
                        X_Row = X_Row + 1
                    Next
               
                    .Cells.Delete
                End With
               
                If X_Height(X) = Empty Then
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).EntireRow.AutoFit
                Else
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).RowHeight = IIf(X_Height(X) > 409, 409, X_Height(X))
                End If
            Next
   
        Case "K9"
            X_Width = Array(S2.Range("R7:AW7").Columns.Width, _
                             S3.Range("S5:AX5").Columns.Width, _
                             S4.Range("S5:AX5").Columns.Width)
                       
            Change_Row_Height = Array(S2.Rows(7), S3.Rows(5), S4.Rows(5))
           
            ReDim X_Height(2)
           
            For X = LBound(X_Width) To UBound(X_Width)
                X_Factor = 5.3
                X_Row = 2
                With S6
                    .Cells.Delete
                    .Cells.Font.Size = S1.Range("A1").Font.Size
                    .Range("A1") = Target.Text
                    .Range("A:A").WrapText = True
                    .Range("A1").VerticalAlignment = xlJustify
                     X_Factor = ((1 + (X_Zoom(X) / 1000 - 0.02)) * X_Factor)
                    .Range("A1").ColumnWidth = X_Width(X) / X_Factor
                    .Range("A1").EntireRow.AutoFit
               
                    My_Data = Split(.Range("A1"), Chr(10))
               
                    For Y = 0 To UBound(My_Data)
                        .Cells(X_Row, 1) = My_Data(Y)
                        X_Height(X) = X_Height(X) + IIf(.Cells(X_Row, 1).RowHeight < 12, 12, .Cells(X_Row, 1).RowHeight)
                        X_Row = X_Row + 1
                    Next
               
                    .Cells.Delete
                End With
               
                If X_Height(X) = Empty Then
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).EntireRow.AutoFit
                Else
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).RowHeight = IIf(X_Height(X) > 409, 409, X_Height(X))
                End If
            Next
   
        Case "K52"
            X_Width = Array(S5.Range("D26:AO26").Columns.Width)
                       
            Change_Row_Height = Array(S5.Rows(26))
           
            ReDim X_Height(0)
           
            For X = LBound(X_Width) To UBound(X_Width)
                X_Factor = 5.3
                X_Row = 2
                With S6
                    .Cells.Delete
                    .Cells.Font.Size = S1.Range("A1").Font.Size
                    .Range("A1") = Target.Text
                    .Range("A:A").WrapText = True
                    .Range("A1").VerticalAlignment = xlJustify
                     X_Factor = ((1 + (X_Zoom(X) / 1000 - 0.02)) * X_Factor)
                    .Range("A1").ColumnWidth = X_Width(X) / X_Factor
                    .Range("A1").EntireRow.AutoFit
               
                    My_Data = Split(.Range("A1"), Chr(10))
               
                    For Y = 0 To UBound(My_Data)
                        .Cells(X_Row, 1) = My_Data(Y)
                        X_Height(X) = X_Height(X) + IIf(.Cells(X_Row, 1).RowHeight < 12, 12, .Cells(X_Row, 1).RowHeight)
                        X_Row = X_Row + 1
                    Next
               
                    .Cells.Delete
                End With
               
                If X_Height(X) = Empty Then
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).EntireRow.AutoFit
                Else
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).RowHeight = IIf(X_Height(X) > 409, 409, X_Height(X))
                End If
            Next
    End Select

    On Error Resume Next
    Sheets("Test").Delete
    On Error GoTo 0
   
    S2.Protect "12345"
    S3.Protect "12345"
    S4.Protect "12345"
    S5.Protect "12345"
   
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set S5 = Nothing
    Set S6 = Nothing

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[malitogan]

Günaydınlar. Korhan bey ilginiz ve cevabınız için teşekkür ederim. Uyguladım. Bilgi'ye uzun veri girdiğimde diğer sayfalarda ver aktardığımız satırların yüksekliği değişiyor. Genişliyor. Bilgi sayfasındaki hücreyi seçip veriyi silince diğer sayfalardaki veriler siliniyor, satırlar eski yüksekliğine dönmüyor, geniş olarak kalıyor. Eğer Bilgi sayfasındaki hücreleri çift tıklayıp içerisine girip de verileri öyle silersem de diğer sayfalarda veri aktardığımız satırların yüksekliği 0 (Sıfır) oluyor. Satırlar gizlenmiş gibi oluyor.

 

[Korhan Ayhan]

Kodu revize ettim. Tekrar deneyiniz.

 

[malitogan]

Korhan Hocam, süpersiniz. Emeğinize sağlık. Allah razı olsun.

 

[malitogan]

2. sorunumla ilgili olarak "https://www.excel.web.tr/threads/metne-goere-satir-yueksekligi.101870/post-554866" linkindeki cevabınızdan faydalanmaya çalışıyorum ancak sürekli hata alıyorum. Müsait bir zamanınızda bakabilir misiniz?

 

[Korhan Ayhan]

Deneyiniz.

KT Tutanak sayfasının kod bölümüne uygulayınız. Ek olarak #2 nolu mesajımdaki koda küçük bir ekleme yaptım. Son halini deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet
    Dim X_Width As Integer, X_Height As Integer
    Dim My_Data As Variant, X_Row As Integer
    Dim X As Integer, X_Factor As Double, X_Zoom As Integer

    If Intersect(Target, Range("C12:AX21")) Is Nothing Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set S1 = Sheets("KT Tutanak")
    X_Zoom = ActiveWindow.Zoom
   
    On Error Resume Next
    Sheets("Test").Delete
    On Error GoTo 0
   
    Sheets.Add
    Set S2 = ActiveSheet
    S2.Name = "Test"
    ActiveWindow.Zoom = X_Zoom
   
    X_Width = S1.Range("C12:AX12").Columns.Width
    X_Row = 2
    X_Factor = 5.3

    With S2
        .Cells.Delete
        .Cells.Font.Size = Target.Font.Size
        .Range("A1") = Target.Text
        .Range("A:A").WrapText = True
        .Range("A1").VerticalAlignment = xlJustify
         X_Factor = ((1 + (ActiveWindow.Zoom / 1000 - 0.02)) * X_Factor)
        .Range("A1").ColumnWidth = X_Width / X_Factor
        .Range("A1").EntireRow.AutoFit

        My_Data = Split(.Range("A1"), Chr(10))

        For X = 0 To UBound(My_Data)
            .Cells(X_Row, 1) = My_Data(X)
            X_Height = X_Height + IIf(.Cells(X_Row, 1).RowHeight < 12, 12, .Cells(X_Row, 1).RowHeight)
            X_Row = X_Row + 1
        Next

        .Cells.Delete
    End With

    If X_Height = Empty Then
        Target.EntireRow.AutoFit
    Else
        Target.RowHeight = IIf(X_Height > 409, 409, X_Height)
    End If
   
    On Error Resume Next
    Sheets("Test").Delete
    On Error GoTo 0
   
    Set S1 = Nothing
    Set S2 = Nothing

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

 

[malitogan]

Korhan Hocam günaydın. Hemen denedim. Gayet iyi çalışıyor. Şu an için herhangi bir problem yok. Elleriniz dert görmesin. Allah'a emanet.

 

[malitogan]

Merhaba,

BİLGİ isimli sayfanızın kod bölümüne uygulayıp deneyiniz.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim S1 As Worksheet, S2 As Worksheet, S3 As Worksheet
    Dim S4 As Worksheet, S5 As Worksheet, S6 As Worksheet
    Dim X_Width As Variant, X_Height As Variant
    Dim My_Data As Variant, X_Row As Integer
    Dim X As Integer, Y As Integer, X_Factor As Double
    Dim WS As Worksheet, Change_Row_Height As Variant
  
    If Intersect(Target, Range("K8:AI9,K52:AI52")) Is Nothing Then Exit Sub

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set S1 = Sheets("Bilgi")
    Set S2 = Sheets("Kapak")
    Set S3 = Sheets("HİK Teklif")
    Set S4 = Sheets("HİK Tutanak")
    Set S5 = Sheets("Rapor")
  
    S2.Unprotect "12345"
    S3.Unprotect "12345"
    S4.Unprotect "12345"
    S5.Unprotect "12345"
  
    On Error Resume Next
    Sheets("Test").Delete
    On Error GoTo 0
  
    Sheets.Add
    Set S6 = ActiveSheet
    S6.Name = "Test"
  
    ReDim X_Zoom(2)
  
    For Each WS In Sheets(Array("Kapak", "HİK Teklif", "HİK Tutanak"))
        WS.Activate
        X_Zoom(X) = ActiveWindow.Zoom
        X = X + 1
    Next
  
    Target.Parent.Select
  
    Select Case Target.Cells(1, 1).Address(0, 0)
        Case "K8"
            X_Width = Array(S2.Range("R6:AW6").Columns.Width, _
                             S3.Range("S4:AX4").Columns.Width, _
                             S4.Range("S4:AX4").Columns.Width)
                      
            Change_Row_Height = Array(S2.Rows(6), S3.Rows(4), S4.Rows(4))
          
            ReDim X_Height(2)
          
            For X = LBound(X_Width) To UBound(X_Width)
                X_Factor = 5.3
                X_Row = 2
                With S6
                    .Cells.Delete
                    .Cells.Font.Size = S1.Range("A1").Font.Size
                    .Range("A1") = Target.Text
                    .Range("A:A").WrapText = True
                    .Range("A1").VerticalAlignment = xlJustify
                     X_Factor = ((1 + (X_Zoom(X) / 1000 - 0.02)) * X_Factor)
                    .Range("A1").ColumnWidth = X_Width(X) / X_Factor
                    .Range("A1").EntireRow.AutoFit
              
                    My_Data = Split(.Range("A1"), Chr(10))
              
                    For Y = 0 To UBound(My_Data)
                        .Cells(X_Row, 1) = My_Data(Y)
                        X_Height(X) = X_Height(X) + IIf(.Cells(X_Row, 1).RowHeight < 12, 12, .Cells(X_Row, 1).RowHeight)
                        X_Row = X_Row + 1
                    Next
              
                    .Cells.Delete
                End With
              
                If X_Height(X) = Empty Then
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).EntireRow.AutoFit
                Else
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).RowHeight = IIf(X_Height(X) > 409, 409, X_Height(X))
                End If
            Next
  
        Case "K9"
            X_Width = Array(S2.Range("R7:AW7").Columns.Width, _
                             S3.Range("S5:AX5").Columns.Width, _
                             S4.Range("S5:AX5").Columns.Width)
                      
            Change_Row_Height = Array(S2.Rows(7), S3.Rows(5), S4.Rows(5))
          
            ReDim X_Height(2)
          
            For X = LBound(X_Width) To UBound(X_Width)
                X_Factor = 5.3
                X_Row = 2
                With S6
                    .Cells.Delete
                    .Cells.Font.Size = S1.Range("A1").Font.Size
                    .Range("A1") = Target.Text
                    .Range("A:A").WrapText = True
                    .Range("A1").VerticalAlignment = xlJustify
                     X_Factor = ((1 + (X_Zoom(X) / 1000 - 0.02)) * X_Factor)
                    .Range("A1").ColumnWidth = X_Width(X) / X_Factor
                    .Range("A1").EntireRow.AutoFit
              
                    My_Data = Split(.Range("A1"), Chr(10))
              
                    For Y = 0 To UBound(My_Data)
                        .Cells(X_Row, 1) = My_Data(Y)
                        X_Height(X) = X_Height(X) + IIf(.Cells(X_Row, 1).RowHeight < 12, 12, .Cells(X_Row, 1).RowHeight)
                        X_Row = X_Row + 1
                    Next
              
                    .Cells.Delete
                End With
              
                If X_Height(X) = Empty Then
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).EntireRow.AutoFit
                Else
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).RowHeight = IIf(X_Height(X) > 409, 409, X_Height(X))
                End If
            Next
  
        Case "K52"
            X_Width = Array(S5.Range("D26:AO26").Columns.Width)
                      
            Change_Row_Height = Array(S5.Rows(26))
          
            ReDim X_Height(0)
          
            For X = LBound(X_Width) To UBound(X_Width)
                X_Factor = 5.3
                X_Row = 2
                With S6
                    .Cells.Delete
                    .Cells.Font.Size = S1.Range("A1").Font.Size
                    .Range("A1") = Target.Text
                    .Range("A:A").WrapText = True
                    .Range("A1").VerticalAlignment = xlJustify
                     X_Factor = ((1 + (X_Zoom(X) / 1000 - 0.02)) * X_Factor)
                    .Range("A1").ColumnWidth = X_Width(X) / X_Factor
                    .Range("A1").EntireRow.AutoFit
              
                    My_Data = Split(.Range("A1"), Chr(10))
              
                    For Y = 0 To UBound(My_Data)
                        .Cells(X_Row, 1) = My_Data(Y)
                        X_Height(X) = X_Height(X) + IIf(.Cells(X_Row, 1).RowHeight < 12, 12, .Cells(X_Row, 1).RowHeight)
                        X_Row = X_Row + 1
                    Next
              
                    .Cells.Delete
                End With
              
                If X_Height(X) = Empty Then
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).EntireRow.AutoFit
                Else
                    Sheets(Change_Row_Height(X).Parent.Name).Rows(Change_Row_Height(X).Address).RowHeight = IIf(X_Height(X) > 409, 409, X_Height(X))
                End If
            Next
    End Select

    On Error Resume Next
    Sheets("Test").Delete
    On Error GoTo 0
  
    S2.Protect "12345"
    S3.Protect "12345"
    S4.Protect "12345"
    S5.Protect "12345"
  
    Set S1 = Nothing
    Set S2 = Nothing
    Set S3 = Nothing
    Set S4 = Nothing
    Set S5 = Nothing
    Set S6 = Nothing

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Korhan Bey, Merhaba.
Bu makro ile çok yardımcı olmuştunuz. Makroyu kullandığım Excel dosyasında kapasite artırmak zorunda kaldım ve birkaç sekme ekledim. Bilgi sayfasına da birkaç satır eklemek zorunda kaldım. Makronun müracaat ettiği sayfalarda herhangi bir değişiklik yapmadım. Rapor ve KT Tutanak sayfalarında herhangi bir sorun yok. Ancak, "Kapak", "HİK Teklif" ve "HİK Tutanak" sayfalarında "işin adı" ile "yüklenici adı"nın yazdığı satırlar içeriğe göre yeterince genişlemiyor. (Daha önce gayet güzel çalışıyordu) Bilmeden bir şeyleri mi bozdum bilemiyorum. Sorunu bulamadım. Rica etsem kontrol edebilir misiniz?
Dosyanın son halini ekliyorum.
Sayfa koruma şifresi : 1969