Kod Kısaltma

[tamer42]

Merhaba,
Aşağıdaki kodda,
Birleşik 2 sütundan sonra bir sütun atlayarak işlem yapıyoruz
Örnek : "O" ve "P" sütunundan sonra "Q" sütununu atlayarak, "R" ve "S" sütununa geçiyoruz. Çünkü aradaki sütunda formül bulunuyor, formüllü sütunları atlıyoruz.
bu şekilde 6 defa tekrar ediyor, dolayısyla her bir işlem için 6 satır yazmak zorunda kalıyorum

bunu nasıl kısaltabiliriz, tek seferde yazamaz mıyız?
teşekkürler,

Set ws = Sayfa1

rs = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row

ws.Activate

ws.Range("O4:P" & rs).ClearContents
ws.Range("R4:S" & rs).ClearContents
ws.Range("U4:V" & rs).ClearContents
ws.Range("X4:Y" & rs).ClearContents
ws.Range("AA4:AB" & rs).ClearContents
ws.Range("AD4:AE" & rs).ClearContents


ws.Range("O4:P" & rs).Interior.Color = xlNone
ws.Range("R4:S" & rs).Interior.Color = xlNone
ws.Range("U4:V" & rs).Interior.Color = xlNone
ws.Range("X4:Y" & rs).Interior.Color = xlNone
ws.Range("AA4:AB" & rs).Interior.Color = xlNone
ws.Range("AD4:AE" & rs).Interior.Color = xlNone

 

[beab05]

Selam;

ve saygılar chatGPT

Sub test()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim columnToClear As Range
   
    Set ws = Sayfa1
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
   
    With ws
        .Activate
        For Each columnToClear In .UsedRange.Columns
            If Not columnToClear.Cells(1).HasFormula Then
                columnToClear.Resize(lastRow).ClearContents
                columnToClear.Resize(lastRow).Interior.Color = xlNone
            End If
        Next columnToClear
    End With
End Sub

 

[tamer42]

Selam;

ve saygılar chatGPT

Sub test()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim columnToClear As Range
  
    Set ws = Sayfa1
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
  
    With ws
        .Activate
        For Each columnToClear In .UsedRange.Columns
            If Not columnToClear.Cells(1).HasFormula Then
                columnToClear.Resize(lastRow).ClearContents
                columnToClear.Resize(lastRow).Interior.Color = xlNone
            End If
        Next columnToClear
    End With
End Sub

Hocam teşekkürler,

yalnız işleme O sütunundan başlayacak işleme AE sütununa kadar devam edecek.
iyi Çalışmalar.

 

[beab05]

Sub test()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim columnToClear As Range
    Dim startColumn As String
    Dim endColumn As String
   
    Set ws = Sayfa1
    lastRow = ws.Cells(ws.Rows.Count, "B").End(xlUp).Row
    startColumn = "O"
    endColumn = "AE"
   
    With ws
        .Activate
        For Each columnToClear In .Range(startColumn & "1:" & endColumn & "1")
            If Not columnToClear.Cells(1).HasFormula Then
                columnToClear.Resize(lastRow).ClearContents
                columnToClear.Resize(lastRow).Interior.Color = xlNone
            End If
        Next columnToClear
    End With

End Sub

 

[veyselemre]

    With Intersect(Range("O4:AF" & Cells(Rows.Count, "B").End(xlUp).Row), Range("O:P,R:S,U:V,X:Y,AA:AB,AD:AE"))
        .ClearContents
        .Interior.ColorIndex = xlNone
    End With

 

[Levent Menteşoğlu]

Bir alternatifte ben önereyim.

Dim alan  As Range

son = Cells(Rows.Count, "B").End(3).Row

Set alan = Rows("4:" & son).SpecialCells(xlCellTypeConstants, 23)

alan.ClearContents
alan.Interior.Color = xlNone

 

[tamer42]

Bir alternatifte ben önereyim.

Dim alan  As Range

son = Cells(Rows.Count, "B").End(3).Row

Set alan = Rows("4:" & son).SpecialCells(xlCellTypeConstants, 23)

alan.ClearContents
alan.Interior.Color = xlNone

Levent Hocam teşekkürler,
yalnız işleme O sütunundan başlayacak işleme AE sütununa kadar devam edecek.
selamlar,

 

[Levent Menteşoğlu]

Levent Hocam teşekkürler,
yalnız işleme O sütunundan başlayacak işleme AE sütununa kadar devam edecek.
selamlar,

Aşağıdaki gibi aralığı değiştirebilirsiniz.

Dim alan  As Range

son = Cells(Rows.Count, "B").End(3).Row

Set alan = Range("O4:AE" & son).SpecialCells(xlCellTypeConstants, 23)

alan.ClearContents
alan.Interior.Color = xlNone

 

[tamer42]

Aşağıdaki gibi aralığı değiştirebilirsiniz.

Dim alan  As Range

son = Cells(Rows.Count, "B").End(3).Row

Set alan = Range("O4:AE" & son).SpecialCells(xlCellTypeConstants, 23)

alan.ClearContents
alan.Interior.Color = xlNone

Levent Hocam çok teşekkürler,

 

[tamer42]

Aşağıdaki gibi aralığı değiştirebilirsiniz.

Dim alan  As Range

son = Cells(Rows.Count, "B").End(3).Row

Set alan = Range("O4:AE" & son).SpecialCells(xlCellTypeConstants, 23)

alan.ClearContents
alan.Interior.Color = xlNone

Levent Hocam birde aşağıdaki gibi iki satırda yaptığımız islemi tek satırda yapabilir miyiz?

                   With ws.Range("O4")
                        .Value = SH.Range("O" & x).Value
                        .Interior.Color = SH.Range("O" & x).Interior.Color
                  End With

 

[Levent Menteşoğlu]

Levent Hocam birde aşağıdaki gibi iki satırda yaptığımız islemi tek satırda yapabilir miyiz?

                   With ws.Range("O4")
                        .Value = SH.Range("O" & x).Value
                        .Interior.Color = SH.Range("O" & x).Interior.Color
                  End With

Aşağıdaki gibi deneyin.

SH.Range("O" & x).copy ws.Range("O4")

Neden tek satıra indirmek istiyorsunuz?

 

[tamer42]

Aşağıdaki gibi deneyin.

SH.Range("O" & x).copy ws.Range("O4")

Neden tek satıra indirmek istiyorsunuz?

Levent Hocam,
Belli bir kurala göre getirilmekte veriler, yani kurala uyan veriler alınıyor.

Kopyalama yapınca kenarlıklar ve diğer başka özelliklerde
sadece değer ve hücre dolgu rengin gelsin istiyorduk.

teşekkürler