- Katılım
- 5 Şubat 2023
- Mesajlar
- 42
- Excel Vers. ve Dili
- Microsoft Ofis 2016 Tr 64 Bit
- Altın Üyelik Bitiş Tarihi
- 05-02-2024
Kod:
Kod:
Sub aktar()
Application.ScreenUpdating = False
Dim renk As Long, s1 As Worksheet, s2 As Worksheet
Dim son1 As Long, son2 As Long, i As Long, s As Long
Set s1 = Sayfa2: Set s2 = Sayfa16
son1 = s1.Cells(Rows.Count, 1).End(3).Row
son2 = s2.Cells(Rows.Count, 2).End(3).Row + s2.Cells(Rows.Count, 7).End(3).Row
s2.Range("A3:I" & son2 + 1).ClearContents
For s = 5 To s1.Cells(2, Columns.Count).End(1).Column
For i = 4 To son1 Step 4
If s1.Cells(i, s).Interior.ColorIndex = 43 Then
son2 = s2.Cells(Rows.Count, 2).End(3).Row + 1
s2.Cells(son2, 1) = son2 - 2
s2.Cells(son2, 2) = s1.Cells(i, 2)
s2.Cells(son2, 3) = s1.Cells(i, 3)
s2.Cells(son2, 4) = CDate(s1.Cells(2, s))
End If
If s1.Cells(i, s).Interior.ColorIndex = 3 Then
son2 = s2.Cells(Rows.Count, 7).End(3).Row + 1
s2.Cells(son2, 6) = son2 - 2
s2.Cells(son2, 7) = s1.Cells(i, 2)
s2.Cells(son2, 8) = s1.Cells(i, 3)
s2.Cells(son2, 9) = CDate(s1.Cells(2, s))
End If
Next i
Next
s2.Columns("A:I").EntireColumn.AutoFit
Set s1 = Nothing: Set s2 = Nothing
son1 = 0: son2 = 0: renk = 0
i = 0: s = 0
Application.ScreenUpdating = True
End Sub
Yukarıda verdiğim kodlar çalışıyor. Ancak veri aldığı sayfada en üstten bir satır ekledim. Artık işlev görmemeye başladı. Satır ekleme yaptığımda kod içerisinde değişmem gereken bir şey var mıdır? Bana yardımcı olursanız müteşekkir kalırım
Şimdiden teşekkür eder,
Saygılarımı sunarım