• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Basit bir site aidat takibi gelir-gider için makro yardım!

Endless033

Endless033

Katılım
25 Haziran 2013
Mesajlar
140
Excel Vers. ve Dili
türkçe
ekli kitaptaki 1-31 arasındaki tüm sayfadaki verileri mizan aylık özet sayfasına aktarılmasını istiyorum bir tuşa bastıkça devamlı günceli o sayfaya yazdırmasını istiyorum.
not: taployu bozmamak bizim için önemli bozmadan olmazsa en yakın kolay yöntemde kafi..şimdiden tşkler.
 

Ekli dosyalar

Aşağıdaki makro istediğiniz işlemi yapar ancak bir sonraki mesajımda yapacağım açıklamalara dikkat etmenizi öneririm:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")

Application.ScreenUpdating = False
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                Sheets(i).[C7:F19].Copy s1.Cells(yeniB, "B")
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
            End If
            If Sheets(i).[B25] <> "" Then
                yeniG = s1.Cells(Rows.Count, "G").End(3).Row + 1
                Sheets(i).[B25:B30].Copy s1.Cells(yeniG, "G")
                Sheets(i).[E25:F30].Copy s1.Cells(yeniG, "H")
                sonG = s1.Cells(Rows.Count, "G").End(3).Row
                's1.Range("A" & yeni & ":A" & sonB) = Sheets(i).[F5]
            End If
        End If
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
 
Öncelikle dosyanızın adı NİSAN olduğundan muhtemelen her ay için ayrı dosya kullanıyorsunuz ve her ay da ayrı ayrı gün sayfalarından oluşuyor. Bu tür kullanım sizin de takdir edeceğiniz gibi çok zor olur. Her aya ayrı dosya, her güne ayrı sayfa, muhtemelen her yıla ayrı klasör derken günlük en fazla 13 satır ayırdığınız işlemler için bir çok dosya ve sayfa oluşturacaksınız. Üstelik ilerde aynı gün 13 satırdan daha fazla işlem olduğunda dosya yapısında değişiklikler yapmanız gerekecek (ya da aynı gün için sayfa kopyalama yapacaksınız).

Olması gereken en ideal dosya yapısı tüm verilerin bir dosyada ve bir sayfada bir veritabanı şeklinde düzenli olarak listelenmesidir. O listeye her işlem yaptığınızda o işlemin bilgilerini satır satır kaydetmelisiniz. Daha sonra isterseniz günlük, isterseniz haftalık, aylık ya da yıllık ya da istediğiniz herhangi bir zaman aralığına ait raporlamaları yapabilirsiniz.

Bir de dosyanızda gelirler için tarih sütunu ayırmışsınız ama giderler için ayırmamışsınız.
 
YUSUF44' Alıntı:
Öncelikle dosyanızın adı NİSAN olduğundan muhtemelen her ay için ayrı dosya kullanıyorsunuz ve her ay da ayrı ayrı gün sayfalarından oluşuyor. Bu tür kullanım sizin de takdir edeceğiniz gibi çok zor olur. Her aya ayrı dosya, her güne ayrı sayfa, muhtemelen her yıla ayrı klasör derken günlük en fazla 13 satır ayırdığınız işlemler için bir çok dosya ve sayfa oluşturacaksınız. Üstelik ilerde aynı gün 13 satırdan daha fazla işlem olduğunda dosya yapısında değişiklikler yapmanız gerekecek (ya da aynı gün için sayfa kopyalama yapacaksınız).

Olması gereken en ideal dosya yapısı tüm verilerin bir dosyada ve bir sayfada bir veritabanı şeklinde düzenli olarak listelenmesidir. O listeye her işlem yaptığınızda o işlemin bilgilerini satır satır kaydetmelisiniz. Daha sonra isterseniz günlük, isterseniz haftalık, aylık ya da yıllık ya da istediğiniz herhangi bir zaman aralığına ait raporlamaları yapabilirsiniz.

Bir de dosyanızda gelirler için tarih sütunu ayırmışsınız ama giderler için ayırmamışsınız.
Genişletmek için tıkla ...
Tarih kısmı her sayfanın üst köşede olduğu için ve gider ve gelir aynı sayfada aynı tarihi teşkil ettiği için gerek duymadım.makro için tşk ederim en kısa zamanda size dönüş yapacağım deneyip ilginiz için tşk ederim dediğimiz gibi 12 ay ayrı ayrı nisan.xlsx gibi her ayın kitabı mevcut sizin aklınızda bir topla ve düzen değişikliğine gidebiliriz yardımcı olursanız makro konusunda zayıfim baya
 
Ben günlük sayfalardaki tarihlerden değil ana sayfadaki tarihten bahsediyorum.

Kod her sayfayı ayrı ayrı kontrol ediyor. Önce gelir kısmını kopyalayıp ana sayfada gelir kısmındaki ilk boş satıra yapıştırıyor ve yapıştırdığı satırlar için o günün tarihini tarih sütununa yazıyor.

Sonra o günün giderlerini kopyalayıp ana sayfadaki gider kısmında ilk boş satıra yapıştırıyor. Ancak ana sayfanın gider kısmında ayrıca tarih sütunu olmadığı için gidersin hangi tarihe ait olduğu belli olmuyor.

Bence sitede benzer konuları araştırın, varsa size uygun bir çalışma o çalışmayı size uyarlamaya çalışalım ya da dosya örneği hazırlayın, gerekli yerlerde yardımcı olmaya çalışalım.
 
YUSUF44' Alıntı:
Ben günlük sayfalardaki tarihlerden değil ana sayfadaki tarihten bahsediyorum.

Kod her sayfayı ayrı ayrı kontrol ediyor. Önce gelir kısmını kopyalayıp ana sayfada gelir kısmındaki ilk boş satıra yapıştırıyor ve yapıştırdığı satırlar için o günün tarihini tarih sütununa yazıyor.

Sonra o günün giderlerini kopyalayıp ana sayfadaki gider kısmında ilk boş satıra yapıştırıyor. Ancak ana sayfanın gider kısmında ayrıca tarih sütunu olmadığı için gidersin hangi tarihe ait olduğu belli olmuyor.

Bence sitede benzer konuları araştırın, varsa size uygun bir çalışma o çalışmayı size uyarlamaya çalışalım ya da dosya örneği hazırlayın, gerekli yerlerde yardımcı olmaya çalışalım.
Genişletmek için tıkla ...
Tamam ben araştırma yapayım.olmadi yenisini düzenler size dönüş yaparım sagolun
 
YUSUF44' Alıntı:
Öncelikle dosyanızın adı NİSAN olduğundan muhtemelen her ay için ayrı dosya kullanıyorsunuz ve her ay da ayrı ayrı gün sayfalarından oluşuyor. Bu tür kullanım sizin de takdir edeceğiniz gibi çok zor olur. Her aya ayrı dosya, her güne ayrı sayfa, muhtemelen her yıla ayrı klasör derken günlük en fazla 13 satır ayırdığınız işlemler için bir çok dosya ve sayfa oluşturacaksınız. Üstelik ilerde aynı gün 13 satırdan daha fazla işlem olduğunda dosya yapısında değişiklikler yapmanız gerekecek (ya da aynı gün için sayfa kopyalama yapacaksınız).

Olması gereken en ideal dosya yapısı tüm verilerin bir dosyada ve bir sayfada bir veritabanı şeklinde düzenli olarak listelenmesidir. O listeye her işlem yaptığınızda o işlemin bilgilerini satır satır kaydetmelisiniz. Daha sonra isterseniz günlük, isterseniz haftalık, aylık ya da yıllık ya da istediğiniz herhangi bir zaman aralığına ait raporlamaları yapabilirsiniz.

Bir de dosyanızda gelirler için tarih sütunu ayırmışsınız ama giderler için ayırmamışsınız.
Genişletmek için tıkla ...
giderler kısmına tarih sutunu ekledim dedğiniz gibi bilgi eksikliği oluyor o şekilde makroyu revize ederseniz sevinirim anca bakabildim işteydim..tam istediğim gibi olmuş bu şekilde işimi görür.bilginiz için tşkler gerçekten
not: komudu çalıştırdığımda her defasında önceki gitirmiş oldugu veriyi silip tekrardan yazdırabilir miyiz.şuan tekrardan çalıştırdığımda altına tekrar aynı veriyi yazıyor
 

Ekli dosyalar

Son düzenleme:
Aşağıdaki makroyu deneyiniz:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")
eski = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "B").End(3).Row, s1.Cells(Rows.Count, "H").End(3).Row)
Application.ScreenUpdating = False
    s1.Range("A6:J" & eski).ClearContents
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                Sheets(i).[C7:F19].Copy s1.Cells(yeniB, "B")
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
            End If
            If Sheets(i).[B25] <> "" Then
                yeniH = s1.Cells(Rows.Count, "H").End(3).Row + 1
                Sheets(i).[B25:B30].Copy s1.Cells(yeniH, "H")
                Sheets(i).[E25:F30].Copy s1.Cells(yeniH, "I")
                sonH = s1.Cells(Rows.Count, "H").End(3).Row
                s1.Range("G" & yeniH & ":G" & sonH) = Sheets(i).[F5]
            End If
        End If
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
 
Bu arada @spacebar 'ın paylaştığı dosya da çok güzel ve kullanışlı. Tebrik ve teşekkür ederim.
 
YUSUF44' Alıntı:
Aşağıdaki makroyu deneyiniz:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")
eski = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "B").End(3).Row, s1.Cells(Rows.Count, "H").End(3).Row)
Application.ScreenUpdating = False
    s1.Range("A6:J" & eski).ClearContents
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                Sheets(i).[C7:F19].Copy s1.Cells(yeniB, "B")
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
            End If
            If Sheets(i).[B25] <> "" Then
                yeniH = s1.Cells(Rows.Count, "H").End(3).Row + 1
                Sheets(i).[B25:B30].Copy s1.Cells(yeniH, "H")
                Sheets(i).[E25:F30].Copy s1.Cells(yeniH, "I")
                sonH = s1.Cells(Rows.Count, "H").End(3).Row
                s1.Range("G" & yeniH & ":G" & sonH) = Sheets(i).[F5]
            End If
        End If
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
Genişletmek için tıkla ...
YUSUF44' Alıntı:
Bu arada @spacebar 'ın paylaştığı dosya da çok güzel ve kullanışlı. Tebrik ve teşekkür ederim.
Genişletmek için tıkla ...
Aynen sağolsun tşk ettim makro için
 
YUSUF44' Alıntı:
Aşağıdaki makroyu deneyiniz:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")
eski = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "B").End(3).Row, s1.Cells(Rows.Count, "H").End(3).Row)
Application.ScreenUpdating = False
    s1.Range("A6:J" & eski).ClearContents
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                Sheets(i).[C7:F19].Copy s1.Cells(yeniB, "B")
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
            End If
            If Sheets(i).[B25] <> "" Then
                yeniH = s1.Cells(Rows.Count, "H").End(3).Row + 1
                Sheets(i).[B25:B30].Copy s1.Cells(yeniH, "H")
                Sheets(i).[E25:F30].Copy s1.Cells(yeniH, "I")
                sonH = s1.Cells(Rows.Count, "H").End(3).Row
                s1.Range("G" & yeniH & ":G" & sonH) = Sheets(i).[F5]
            End If
        End If
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
Genişletmek için tıkla ...
Yusuf bey her komutta çalıştırdığında onceki veriyi siliyor dimi
 
Deneyip görün bence. Clearcontents satırı onun için var.
 
YUSUF44' Alıntı:
Bu arada @spacebar 'ın paylaştığı dosya da çok güzel ve kullanışlı. Tebrik ve teşekkür ederim.
Genişletmek için tıkla ...
merhabalar. abim için yapmıştım. makro etkinleştirme bilmediği için sadece formüllerle yaptım. isterseniz kendi ihtiyaçlarınıza göre geliştirebilirsiniz. iyi hafta sonları dilerim.
 
YUSUF44' Alıntı:
Aşağıdaki makroyu deneyiniz:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")
eski = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "B").End(3).Row, s1.Cells(Rows.Count, "H").End(3).Row)
Application.ScreenUpdating = False
    s1.Range("A6:J" & eski).ClearContents
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                Sheets(i).[C7:F19].Copy s1.Cells(yeniB, "B")
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
            End If
            If Sheets(i).[B25] <> "" Then
                yeniH = s1.Cells(Rows.Count, "H").End(3).Row + 1
                Sheets(i).[B25:B30].Copy s1.Cells(yeniH, "H")
                Sheets(i).[E25:F30].Copy s1.Cells(yeniH, "I")
                sonH = s1.Cells(Rows.Count, "H").End(3).Row
                s1.Range("G" & yeniH & ":G" & sonH) = Sheets(i).[F5]
            End If
        End If
    Next
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
Genişletmek için tıkla ...
yusuf bey aktarınca tablo kenarlık çizgilerle beraber aktarıyor tarih kısmını aktarmayınca iyi olmadı ya tamamen aktarmasın yada düzenli aktarma yapma şanşımız varsa aktarada bilir.
 
Aşağıdaki gibi deneyin:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")
eski = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "B").End(3).Row, s1.Cells(Rows.Count, "H").End(3).Row)
Application.ScreenUpdating = False
    s1.Range("A6:J" & eski).Clear
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                Sheets(i).[C7:F19].Copy: s1.Cells(yeniB, "B").PasteSpecial Paste:=xlValues
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
                With s1.Range("A" & yeniB & ":E" & sonB)
                    .Borders.LineStyle = 9
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).Weight = xlHairline
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).Weight = xlHairline
                End With
            End If
            If Sheets(i).[B25] <> "" Then
                yeniH = s1.Cells(Rows.Count, "H").End(3).Row + 1
                Sheets(i).[B25:B30].Copy: s1.Cells(yeniH, "H").PasteSpecial Paste:=xlValues
                Sheets(i).[E25:F30].Copy: s1.Cells(yeniH, "I").PasteSpecial Paste:=xlValues
                sonH = s1.Cells(Rows.Count, "H").End(3).Row
                s1.Range("G" & yeniH & ":G" & sonH) = Sheets(i).[F5]
                With s1.Range("G" & yeniH & ":J" & sonH)
                    .Borders.LineStyle = 9
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).Weight = xlHairline
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).Weight = xlHairline
                End With
            End If
        End If
    Next
    ensonB = s1.Cells(Rows.Count, "B").End(3).Row
    s1.Range("A6:A" & ensonB).NumberFormat = "dd/mm/yyyy"
    s1.Range("A6:A" & ensonB).HorizontalAlignment = xlCenter
    s1.Range("D6:D" & ensonB).HorizontalAlignment = xlCenter
    s1.Range("E6:E" & ensonB).NumberFormat = "$#,##0.00_);($#,##0.00)"
    s1.Range("A6:E" & ensonB).VerticalAlignment = xlCenter
    
    ensonG = s1.Cells(Rows.Count, "G").End(3).Row
    s1.Range("G6:G" & ensonG).NumberFormat = "dd/mm/yyyy"
    s1.Range("G6:G" & ensonG).HorizontalAlignment = xlCenter
    s1.Range("I6:I" & ensonG).HorizontalAlignment = xlCenter
    s1.Range("J6:J" & ensonG).NumberFormat = "$#,##0.00_);($#,##0.00)"
    s1.Range("G6:J" & ensonG).VerticalAlignment = xlCenter
    
    s1.Columns("A:J").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
 
YUSUF44' Alıntı:
Aşağıdaki gibi deneyin:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")
eski = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "B").End(3).Row, s1.Cells(Rows.Count, "H").End(3).Row)
Application.ScreenUpdating = False
    s1.Range("A6:J" & eski).Clear
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                Sheets(i).[C7:F19].Copy: s1.Cells(yeniB, "B").PasteSpecial Paste:=xlValues
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
                With s1.Range("A" & yeniB & ":E" & sonB)
                    .Borders.LineStyle = 9
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).Weight = xlHairline
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).Weight = xlHairline
                End With
            End If
            If Sheets(i).[B25] <> "" Then
                yeniH = s1.Cells(Rows.Count, "H").End(3).Row + 1
                Sheets(i).[B25:B30].Copy: s1.Cells(yeniH, "H").PasteSpecial Paste:=xlValues
                Sheets(i).[E25:F30].Copy: s1.Cells(yeniH, "I").PasteSpecial Paste:=xlValues
                sonH = s1.Cells(Rows.Count, "H").End(3).Row
                s1.Range("G" & yeniH & ":G" & sonH) = Sheets(i).[F5]
                With s1.Range("G" & yeniH & ":J" & sonH)
                    .Borders.LineStyle = 9
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).Weight = xlHairline
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).Weight = xlHairline
                End With
            End If
        End If
    Next
    ensonB = s1.Cells(Rows.Count, "B").End(3).Row
    s1.Range("A6:A" & ensonB).NumberFormat = "dd/mm/yyyy"
    s1.Range("A6:A" & ensonB).HorizontalAlignment = xlCenter
    s1.Range("D6:D" & ensonB).HorizontalAlignment = xlCenter
    s1.Range("E6:E" & ensonB).NumberFormat = "$#,##0.00_);($#,##0.00)"
    s1.Range("A6:E" & ensonB).VerticalAlignment = xlCenter
   
    ensonG = s1.Cells(Rows.Count, "G").End(3).Row
    s1.Range("G6:G" & ensonG).NumberFormat = "dd/mm/yyyy"
    s1.Range("G6:G" & ensonG).HorizontalAlignment = xlCenter
    s1.Range("I6:I" & ensonG).HorizontalAlignment = xlCenter
    s1.Range("J6:J" & ensonG).NumberFormat = "$#,##0.00_);($#,##0.00)"
    s1.Range("G6:J" & ensonG).VerticalAlignment = xlCenter
   
    s1.Columns("A:J").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
Genişletmek için tıkla ...
yusuf bey tşk ederim gayet güzel olmuş tarih arasınıda ayırması daha güzel olmuş emeğinize sağlık
 
YUSUF44' Alıntı:
Aşağıdaki gibi deneyin:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")
eski = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "B").End(3).Row, s1.Cells(Rows.Count, "H").End(3).Row)
Application.ScreenUpdating = False
    s1.Range("A6:J" & eski).Clear
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                Sheets(i).[C7:F19].Copy: s1.Cells(yeniB, "B").PasteSpecial Paste:=xlValues
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
                With s1.Range("A" & yeniB & ":E" & sonB)
                    .Borders.LineStyle = 9
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).Weight = xlHairline
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).Weight = xlHairline
                End With
            End If
            If Sheets(i).[B25] <> "" Then
                yeniH = s1.Cells(Rows.Count, "H").End(3).Row + 1
                Sheets(i).[B25:B30].Copy: s1.Cells(yeniH, "H").PasteSpecial Paste:=xlValues
                Sheets(i).[E25:F30].Copy: s1.Cells(yeniH, "I").PasteSpecial Paste:=xlValues
                sonH = s1.Cells(Rows.Count, "H").End(3).Row
                s1.Range("G" & yeniH & ":G" & sonH) = Sheets(i).[F5]
                With s1.Range("G" & yeniH & ":J" & sonH)
                    .Borders.LineStyle = 9
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).Weight = xlHairline
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).Weight = xlHairline
                End With
            End If
        End If
    Next
    ensonB = s1.Cells(Rows.Count, "B").End(3).Row
    s1.Range("A6:A" & ensonB).NumberFormat = "dd/mm/yyyy"
    s1.Range("A6:A" & ensonB).HorizontalAlignment = xlCenter
    s1.Range("D6:D" & ensonB).HorizontalAlignment = xlCenter
    s1.Range("E6:E" & ensonB).NumberFormat = "$#,##0.00_);($#,##0.00)"
    s1.Range("A6:E" & ensonB).VerticalAlignment = xlCenter
   
    ensonG = s1.Cells(Rows.Count, "G").End(3).Row
    s1.Range("G6:G" & ensonG).NumberFormat = "dd/mm/yyyy"
    s1.Range("G6:G" & ensonG).HorizontalAlignment = xlCenter
    s1.Range("I6:I" & ensonG).HorizontalAlignment = xlCenter
    s1.Range("J6:J" & ensonG).NumberFormat = "$#,##0.00_);($#,##0.00)"
    s1.Range("G6:J" & ensonG).VerticalAlignment = xlCenter
   
    s1.Columns("A:J").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
Genişletmek için tıkla ...
Yusuf bey sizi tekrardan rahatsız ediyorum kusura bakmayın taploda gelir ve gider şeklinde belirli bir satır ve sutun aralığı Sheets(i).[C7:F19].Copy: s1.Cells(yeniB, "B").PasteSpecial Paste:=xlValues , Sheets(i).[B25:B30].Copy: s1.Cells(yeniH, "H").PasteSpecial Paste:=xlValues mesala bu alanları son dolu veriye kadar gibi bir kod yazamazmıyız araya satır eklemem gereken durumlar oluyor bu taplo bu şeklide olacağı için bunun dışına çıkmamam gerekli onun için ne kadar satır eklersem ekleyeyim son dolu veriye göre aktarmasını yazabilirmisiniz
 
Merhaba, estağfurullah. Deneyiniz:

PHP: 
Sub toparla()
Set s1 = Sheets("MİZAN AYLIK ÖZET")
eski = WorksheetFunction.Max(6, s1.Cells(Rows.Count, "B").End(3).Row, s1.Cells(Rows.Count, "H").End(3).Row)
Application.ScreenUpdating = False
    s1.Range("A6:J" & eski).Clear
    For i = 1 To Sheets.Count
        If Sheets(i).Name <> s1.Name Then
            If Sheets(i).[C7] <> "" Then
                yeniB = s1.Cells(Rows.Count, "B").End(3).Row + 1
                songelir = Sheets(i).Cells.Find("GÜNÜN TAHSİLAT TOPLAMI", , , , xlByRows, xlPrevious).Row - 1
                Sheets(i).Range("C7:F" & songelir).Copy: s1.Cells(yeniB, "B").PasteSpecial Paste:=xlValues
                sonB = s1.Cells(Rows.Count, "B").End(3).Row
                s1.Range("A" & yeniB & ":A" & sonB) = Sheets(i).[F5]
                With s1.Range("A" & yeniB & ":E" & sonB)
                    .Borders.LineStyle = 9
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).Weight = xlHairline
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).Weight = xlHairline
                End With
            End If
            If Sheets(i).[B25] <> "" Then
                yeniH = s1.Cells(Rows.Count, "H").End(3).Row + 1
                ilkgider = Sheets(i).Cells.Find("HARCAMALAR", , , , xlByRows, xlPrevious).Row + 1
                songider = Sheets(i).Cells.Find("TOPLAM HARCAMA", , , , xlByRows, xlPrevious).Row - 1
                Sheets(i).Range("B" & ilkgider & ":B" & songider).Copy s1.Cells(yeniH, "H")
                Sheets(i).Range("E" & ilkgider & ":F" & songider).Copy s1.Cells(yeniH, "I")
                sonH = s1.Cells(Rows.Count, "H").End(3).Row
                s1.Range("G" & yeniH & ":G" & sonH) = Sheets(i).[F5]
                With s1.Range("G" & yeniH & ":J" & sonH)
                    .Borders.LineStyle = 9
                    .Borders(xlInsideVertical).LineStyle = xlContinuous
                    .Borders(xlInsideVertical).Weight = xlHairline
                    .Borders(xlInsideHorizontal).LineStyle = xlContinuous
                    .Borders(xlInsideHorizontal).Weight = xlHairline
                End With
            End If
        End If
    Next
    ensonB = s1.Cells(Rows.Count, "B").End(3).Row
    s1.Range("A6:A" & ensonB).NumberFormat = "dd/mm/yyyy"
    s1.Range("A6:A" & ensonB).HorizontalAlignment = xlCenter
    s1.Range("D6:D" & ensonB).HorizontalAlignment = xlCenter
    s1.Range("E6:E" & ensonB).NumberFormat = "$#,##0.00_);($#,##0.00)"
    s1.Range("A6:E" & ensonB).VerticalAlignment = xlCenter
    s1.Range("A6:E" & ensonB).Font.Bold = False
    
    ensonG = s1.Cells(Rows.Count, "G").End(3).Row
    s1.Range("G6:G" & ensonG).NumberFormat = "dd/mm/yyyy"
    s1.Range("G6:G" & ensonG).HorizontalAlignment = xlCenter
    s1.Range("I6:I" & ensonG).HorizontalAlignment = xlCenter
    s1.Range("J6:J" & ensonG).NumberFormat = "$#,##0.00_);($#,##0.00)"
    s1.Range("G6:J" & ensonG).VerticalAlignment = xlCenter
    s1.Range("G6:J" & ensonG).Font.Bold = False
    s1.Range("J6:J" & ensonG).HorizontalAlignment = xlRight
    
    s1.Columns("A:J").EntireColumn.AutoFit
Application.ScreenUpdating = True
MsgBox "İşlem tamamlandı.", vbInformation
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst