Option Explicit
Sub GELİR_SAYFALARINI_BİRLEŞTİR()
Dim S1 As Worksheet, SAYFA As Worksheet, SATIR As Integer, SAY As Integer
Dim X As Byte, AYLAR() As Variant
Set S1 = Sheets("YILLIK GELİR")
AYLAR = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
Application.ScreenUpdating = False
S1.Range("C6:H6005").ClearContents
For X = 0 To 11
Set SAYFA = Sheets(AYLAR(X) & " GELİR")
If S1.Range("C6005") <> "" Then GoTo Son
If SAYFA.Range("C6") = "" Then GoTo Devam
If SAYFA.Range("C505") <> "" Then
SATIR = S1.Cells(6006, "D").End(3).Offset(0, -1).Row
If (SATIR - 5 + 500) > 6000 Then GoTo Son
S1.Range("C6:H" & SATIR + 500).Value = SAYFA.Range("C6:H505").Value
Else
SATIR = S1.Cells(6006, "D").End(3).Offset(0, -1).Row
SAY = SAYFA.Range("D506").End(3).Row - 5
If (SATIR - 5 + SAY) > 6000 Then GoTo Son
S1.Range("C" & SATIR + 1 & ":H" & SATIR + SAY).Value = SAYFA.Range("C6:H" & SAYFA.Range("D506").End(3).Row).Value
End If
Devam: Next
Set S1 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
Exit Sub
Son:
Set S1 = Nothing
Application.ScreenUpdating = True
MsgBox "YILLIK GELİR sayfası dolmuştur !" & Chr(10) & "Lütfen satır ekleyiniz !", vbCritical
End Sub
yukarıdaki koda sayfadaki filtre leri temizleyip ondan sonra aktarma illemini yapmak istiyorum yardımcı olabilirmisiniz
Sub GELİR_SAYFALARINI_BİRLEŞTİR()
Dim S1 As Worksheet, SAYFA As Worksheet, SATIR As Integer, SAY As Integer
Dim X As Byte, AYLAR() As Variant
Set S1 = Sheets("YILLIK GELİR")
AYLAR = Array("OCAK", "ŞUBAT", "MART", "NİSAN", "MAYIS", "HAZİRAN", "TEMMUZ", "AĞUSTOS", "EYLÜL", "EKİM", "KASIM", "ARALIK")
Application.ScreenUpdating = False
S1.Range("C6:H6005").ClearContents
For X = 0 To 11
Set SAYFA = Sheets(AYLAR(X) & " GELİR")
If S1.Range("C6005") <> "" Then GoTo Son
If SAYFA.Range("C6") = "" Then GoTo Devam
If SAYFA.Range("C505") <> "" Then
SATIR = S1.Cells(6006, "D").End(3).Offset(0, -1).Row
If (SATIR - 5 + 500) > 6000 Then GoTo Son
S1.Range("C6:H" & SATIR + 500).Value = SAYFA.Range("C6:H505").Value
Else
SATIR = S1.Cells(6006, "D").End(3).Offset(0, -1).Row
SAY = SAYFA.Range("D506").End(3).Row - 5
If (SATIR - 5 + SAY) > 6000 Then GoTo Son
S1.Range("C" & SATIR + 1 & ":H" & SATIR + SAY).Value = SAYFA.Range("C6:H" & SAYFA.Range("D506").End(3).Row).Value
End If
Devam: Next
Set S1 = Nothing
Application.ScreenUpdating = True
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
Exit Sub
Son:
Set S1 = Nothing
Application.ScreenUpdating = True
MsgBox "YILLIK GELİR sayfası dolmuştur !" & Chr(10) & "Lütfen satır ekleyiniz !", vbCritical
End Sub
yukarıdaki koda sayfadaki filtre leri temizleyip ondan sonra aktarma illemini yapmak istiyorum yardımcı olabilirmisiniz
