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

Korhan Ayhan · Cuma saat 11:41'de

Tekrar revize ettim..

Hsn55 · Cumartesi saat 05:25'de

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 · Cumartesi saat 07:35'de

C++:

WS.Range("D7:D50").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True

Hsn55 · Cumartesi saat 08:07'de

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

Hsn55 · Cumartesi saat 08:18'de

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 · Pazar saat 18:16'de

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

Kodu bu talebinize göre tekrar revie ettim...

Hsn55 · Pazar saat 19:05'de

Korhan hocam çok teşekkür ederim. Emeğinize sağlık iyi bayramlar

Hsn55 · Salı saat 04:31'de

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

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 · Salı saat 15:16'de

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

Hsn55 · Dün 09:47 da

Korhan Ayhan' Alıntı:

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

Tekrar teşekkür ediyorum

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

Korhan Ayhan

Administrator

Hsn55

Korhan Ayhan

Administrator

Hsn55

Hsn55

Korhan Ayhan

Administrator

Hsn55

Hsn55

ARIZA_TESPIT_RAPORU.xlsm dosyasını indir - download

Korhan Ayhan

Administrator

Hsn55