Soru Birleştirilmiş Hücrede Girilen Veriye Göre Satır Genişlemesi

H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
522
Excel Vers. ve Dili
2010, Türkiye
Korhan hocam çok teşekkür ederim. Emeğinize sağlık .Birşey öğrenmek istiyorum. Eğer ki A,B,C,D sayfalarında ben D7:N50 satırları arasında veri olmayan satırların gizlenmesini değiştirmek istediğimde örneğin D10:N50 arası yapmak istiyorum.Hangi makroda hangi satırda işlem yapmam gerekiyor?
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,874
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
C++: 
WS.Range("D7:D50").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
522
Excel Vers. ve Dili
2010, Türkiye
Günaydın;
Hocam makronun C7:R50 hücre aralığında tetiklenmesi için aşağıdaki satırı değiştirdiğimde makro hata veriyor.Birde hocam D sütundaki herhangi bir satırı sildiğim zaman sıra numarasını da sildirebilir miyiz
Kod: 
If Not Intersect(Target, Range("C7:R50")) Is Nothing Then
Hata satırı
Kod: 
.Cells.Delete
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
522
Excel Vers. ve Dili
2010, Türkiye
Kodu If Not Intersect(Target, Range("D7:R50")) Is Nothing Then
Aralığında yaptığım zaman hata vermiyor. Sıra numarasını silme işlemi D sütünundaki hücreyi sildiğimizde olabilirse sorun kalmayacak görünüyor hocam
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,874
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Hsn55' Alıntı:
Kodu If Not Intersect(Target, Range("D7:R50")) Is Nothing Then
Aralığında yaptığım zaman hata vermiyor. Sıra numarasını silme işlemi D sütünundaki hücreyi sildiğimizde olabilirse sorun kalmayacak görünüyor hocam
Genişletmek için tıkla ...
Kodu bu talebinize göre tekrar revie ettim...
 
H

Hsn55

Katılım
7 Şubat 2021
Mesajlar
522
Excel Vers. ve Dili
2010, Türkiye
Korhan bey merhabalar;
Makroyu asıl dosyama uyarladım. Bazı hücrelerin bozulması için sayfaya koruma ekledim. Fakat makro hata veriyor. Bakabilir misiniz. Şifre :1978

ARIZA_TESPIT_RAPORU.xlsm dosyasını indir - download

ARIZA_TESPIT_RAPORU.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle
s6.dosya.tc s6.dosya.tc
Kod: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Sheets("ARAÇ VERİ GİRİŞİ").Unprotect 1978
    If Not Intersect(Target, Range("D30:R80")) Is Nothing Then
        Dim WS As Worksheet, S1 As Worksheet, S2 As Worksheet
        Dim XWidth As Integer, XHeight As Integer
        Dim Rng As Range, My_Data As Variant, Last_Row As Long
        Dim No As Integer, X As Integer, Count As Integer
           
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
       
        Set S1 = Sheets("ARAÇ VERİ GİRİŞİ")
        S1.Range("C30:C80").VerticalAlignment = xlCenter
        S1.Range("C30:C80").ClearContents
        S1.Range("D30:N80").WrapText = True
        S1.Range("D30:N80").EntireRow.AutoFit
       
        For Each WS In Sheets(Array("ARIZA TESPİT RAPORU", "TAMİR SONRASI FORM"))
            S1.Range("C30:R80").Copy WS.Range("C30:R80")
            WS.Range("D30:N80").WrapText = True
            WS.Range("D30:N80").EntireRow.AutoFit
     
        Next
       
        On Error Resume Next
        Sheets("Test").Delete
        On Error GoTo 0
       
        Sheets.Add
        Set S2 = ActiveSheet
        S2.Name = "Test"
       
        For Each Rng In S1.Range("D30:N80").Columns(1).Cells
            If Rng.Value <> "" Then
                XWidth = S1.Range("D30:N30").Columns.Width
                XHeight = 0
               
                No = 2
               
                With S2
                    .Cells.Delete
                    .Cells.Font.Size = Rng.Font.Size
                    .Range("A1") = Rng.Value
                    .Range("A:A").WrapText = True
                    .Range("A1").VerticalAlignment = xlJustify
                    .Range("A1").ColumnWidth = XWidth / 5.3
                    .Range("A1").EntireRow.AutoFit
                   
                    My_Data = Split(.Range("A1"), Chr(10))
                   
                    For X = 0 To UBound(My_Data)
                        .Cells(No, 1) = My_Data(X)
                        XHeight = XHeight + .Cells(No, 1).RowHeight
                        No = No + 1
                    Next
                   
                    .Cells.Delete
                End With
             
                If XHeight = 0 Then XHeight = 15
                Rng.RowHeight = XHeight
               
                S1.Range("C30") = 1
                Last_Row = S1.Cells(100, 4).End(3).Row - 29
                S1.Range("C30").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=Last_Row, Trend:=False
               
                For Each WS In Sheets(Array("ARIZA TESPİT RAPORU", "TAMİR SONRASI FORM"))
                    S1.Range("C30:R80").Copy WS.Range("C30:R80")
                    WS.Range("D30:N80").WrapText = True
                    WS.Rows(Rng.Row).RowHeight = XHeight
                    WS.Range("D35:D85").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
       
 
               Next
            End If
        Next
   
        On Error Resume Next
        S2.Delete
        On Error GoTo 0
       
        Set S1 = Nothing
        Set S2 = Nothing
        Set WS = Nothing
   
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End If
Sheets("ARAÇ VERİ GİRİŞİ").Protect 1978
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,874
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Kodu aşağıdaki şekilde güncellerseniz benim önerim için hata mesajından kurtulabilirsiniz.

Ama koruma ekleyince başka kodlarınız hata verebilir. Onlarıda kontrol etmeniz gerekir.

C++: 
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("D30:R80")) Is Nothing Then
        Dim WS As Worksheet, S1 As Worksheet, S2 As Worksheet
        Dim XWidth As Integer, XHeight As Integer
        Dim Rng As Range, My_Data As Variant, Last_Row As Long
        Dim No As Integer, X As Integer, Count As Integer
            
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        Application.EnableEvents = False
        
        Set S1 = Sheets("ARAÇ VERİ GİRİŞİ")
        S1.Unprotect 1978
        S1.Range("C30:C80").VerticalAlignment = xlCenter
        S1.Range("C30:C80").ClearContents
        S1.Range("D30:N80").WrapText = True
        S1.Range("D30:N80").EntireRow.AutoFit
        
        For Each WS In Sheets(Array("ARIZA TESPİT RAPORU", "TAMİR SONRASI FORM"))
            S1.Range("C30:R80").Copy WS.Range("C30:R80")
            WS.Range("D30:N80").WrapText = True
            WS.Range("D30:N80").EntireRow.AutoFit
        Next
        
        On Error Resume Next
        Sheets("Test").Delete
        On Error GoTo 0
        
        Sheets.Add
        Set S2 = ActiveSheet
        S2.Name = "Test"
        
        For Each Rng In S1.Range("D30:N80").Columns(1).Cells
            If Rng.Value <> "" Then
                XWidth = S1.Range("D30:N30").Columns.Width
                XHeight = 0
                
                No = 2
                
                With S2
                    .Cells.Delete
                    .Cells.Font.Size = Rng.Font.Size
                    .Range("A1") = Rng.Value
                    .Range("A:A").WrapText = True
                    .Range("A1").VerticalAlignment = xlJustify
                    .Range("A1").ColumnWidth = XWidth / 5.3
                    .Range("A1").EntireRow.AutoFit
                    
                    My_Data = Split(.Range("A1"), Chr(10))
                    
                    For X = 0 To UBound(My_Data)
                        .Cells(No, 1) = My_Data(X)
                        XHeight = XHeight + .Cells(No, 1).RowHeight
                        No = No + 1
                    Next
                    
                    .Cells.Delete
                End With
              
                If XHeight = 0 Then XHeight = 15
                Rng.RowHeight = XHeight
                
                S1.Range("C30") = 1
                Last_Row = S1.Cells(100, 4).End(3).Row - 29
                S1.Range("C30").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Step:=1, Stop:=Last_Row, Trend:=False
                
                For Each WS In Sheets(Array("ARIZA TESPİT RAPORU", "TAMİR SONRASI FORM"))
                    S1.Range("C30:R80").Copy WS.Range("C30:R80")
                    WS.Range("D30:N80").WrapText = True
                    WS.Rows(Rng.Row).RowHeight = XHeight
                    WS.Range("D35:D85").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
                Next
            End If
        Next
    
        On Error Resume Next
        S2.Delete
        On Error GoTo 0
        
        S1.Protect 1978
        
        Set S1 = Nothing
        Set S2 = Nothing
        Set WS = Nothing
    
        Application.EnableEvents = True
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
    End If
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst