• DİKKAT

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

Sayfa birleştirme

B

burcin_end_muh

Altın Üye
Katılım
14 Ocak 2013
Mesajlar
167
Excel Vers. ve Dili
Türkçe 2013
Merhaba arkadaşlar daha önce de defalarca konu açmıştım ama henuz çözüme ulasmadı. forumda da arattım bulmus degılım.

Konu şu: bir klasor ıcınde 2 tane dosyam var adları a ve b olsun. a dosyasının 1nci sayfasıyla b dosyasının 1ncı sayfasını.. a nın 2ncı sayfasıyla b nın 2ncı sayfasını bırlestırmek ıstıyorum.

Bu en basıt sekılde ıfade edısım. aslında dosya sayısı oldukca fazla.

Yardımlarınızı beklıyorum arkadaslar. şimdiden çok teşekkürler.
 
aslında sitede çok örnek var bu konuda.

biraz daha bilgiye ihtiyaç var.

ben varsayımlar ile ilerledim.
1- sayfa1'lerin ve sayfa2'lerin tablo yapısı aynı.
2- bütün sayfalarda 1. satırlar sütun başlığı. (kod başlık satırını kopyalamıyor. el ile eklenebilir.)
3- aşağıdaki kodların kopyalanacağı dosya konsolidasyon dosyası ve birleştirlecek olan dosyaların bulunduğu klasörden farklı bir klasörde yer alıyor.
4- birleştirilecek dosyalarda mutlaka en az 2 sayfa var. en solda yer alan 1 no.lu sayfa. hemen sağındaki 2 no.lu sayfa.

Kod: 
Sub Dosya_Konsolidasyon()
    
    Dim fName, fPath As String
    Dim kwb As Workbook, wb As Workbook
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rng1 As Range, rng2 As Range
    Dim calc As Long
    
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
        .EnableEvents = False
        calc = .Calculation
        .Calculation = xlCalculationManual
    End With
    
    Set kwb = ThisWorkbook 'bu kodun kopyalanacağı ve dosyaların birleştirileceği dosya
    With kwb
        .Worksheets(1).Name = "konsolide1"
        Set ws1 = .Worksheets("konsolide1")
        ws1.Cells.Clear 'kod tekrar çalıştırılmak istendiğinde eski verileri silmek için
        If .Worksheets.Count = 1 Then .Worksheets.Add after:=.Worksheets(.Worksheets.Count)
        .Worksheets(2).Name = "konsolide2"
        Set ws2 = .Worksheets("konsolide2")
        ws2.Cells.Clear
    End With

    fPath = "C:\Dosyalar\birleşecek_dosyalar\" 'dosyaların bulunduğu klasörün tam yolu ile değiştir. sondaki \ mutlaka olmalı
    fName = Dir(fPath & "*.xls*")
    
    Do While fName <> ""
        Set wb = Workbooks.Open(fPath & fName)
        Set rng1 = wb.Worksheets(1).Cells(1).CurrentRegion
        Set rng2 = wb.Worksheets(2).Cells(1).CurrentRegion
        
        rng1.Offset(1).Resize(rng1.Rows.Count - 1).Copy ws1.Range("A" & Rows.Count).End(xlUp).Offset(1)
        rng2.Offset(1).Resize(rng2.Rows.Count - 1).Copy ws2.Range("A" & Rows.Count).End(xlUp).Offset(1)

        wb.Close SaveChanges:=False
        fName = Dir()
    Loop

    kwb.Save
    
    With Application
        .CutCopyMode = False
        .DisplayAlerts = True
        .ScreenUpdating = True
        .EnableEvents = True
        .Calculation = calc
    End With

End Sub
 
ADO ile bu şekilde de yapabilirsiniz;

Kod: 
DefObj C-D, F, R
Sub Sayfaları_Al()
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Con = CreateObject("adodb.connection")
    Set Rs = CreateObject("adodb.recordset")
    For Each Dosya In Fso.GetFolder([COLOR="red"]ThisWorkbook.Path[/COLOR]).Files
        If Dosya.Name <> ThisWorkbook.Name Then
            Con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
            Dosya & ";extended Properties=""excel 12.0;hdr=yes"""
            Set Rs = Con.Execute("Select * from [[COLOR="Red"]Sayfa1[/COLOR]$]")
            Sheets("[COLOR="red"]Sayfa1[/COLOR]").Range("A65536").End(3)(2, 1).CopyFromRecordset Rs
            Rs.Close
            
            Set Rs = Con.Execute("Select * from [[COLOR="red"]Sayfa2[/COLOR]$]")
            Sheets("[COLOR="red"]Sayfa2[/COLOR]).Range("A65536").End(3)(2, 1).CopyFromRecordset Rs
            Rs.Close
            Con.Close
        End If
   Next Dosya
   Set Fso = Nothing: Set Con = Nothing: Set Rs = Nothing: Set Dosya = Nothing
End Sub

Dikkat edilmesi gereken noktalar:
■ Veri alınacak dosyalar aynı klasör içerisinde olmalı.
■ Veri alınacak dosyaların sayfa isimleri Sayfa1 ve Sayfa2 olmalı. Ya da veri alınacak dosyaların sayfa isimleri ne ise, kodlara da o sayfa isimleri yazılmalı. Değişiklik yapılabilecek yerleri kırmızı ile belirttim.
 
Dostlar çok teşekkürler!!! Yeni gördüm cevapları normalde mail geliyordu biri cevap yazınca ama görmemişim sanırım. neyse. murat, abı senınkı daha anlasılır duruyordu denedım oldu gayet guzel calısıyor elıne saglık. Sonunda hata gıbı bısey verıyor ama calısıyor
tekrar cok tesekkur edıyorum. bırseyler daha eklemeye calısacagım raporun daha hızlı ve duzenlı olusması ıcın bakalım dogru yere ekleyebılecek mıyım cok saolun.
 
Rica ederim..

Eğer yapamazsanız yine yardımcı oluruz.

İyi günler.
 
dostum bıseyler yaptım ama sorunlar yasadım
dosyaları bırlestırınce ıstenmeyen bos satırlar ve reklam ıceren satırlar olustu bunları sılmek ıcın makrolar buldum toparladım hepsı tek tek calısıyor. amacım bırlestırmek ama yapamadım. aynı sub-end arasına koydum olmadı Call kullanmaya calıstım yıne olmadı. sımdı oncelıklı ıstegım bu makroları bırlestırmek ve her ıkı sayfada da (YEREL , ITHAL) uygulanmıs olması.
son olarak da bu toparlanmıs verılerın basına baslık atmak ıstıyorum

Brick, Brick Adı, Kutu, YTL, Toplam Kutu, Toplam YTL, Pazar Payı Kutu, Pazar Payı YTL

Kullanmak ıstedıgım baslıklar da bunlar, yıne her ıkı sayfanın da basında yazması gerek.

Yardımcı olursanız her hafta basında harcadıgım 2bucuk saat 10 dk ya ınmıs olacak arkadaslar. cok tesekkurler. Dosyalar ektedır.

https://drive.google.com/folderview?id=0B4AeEngVSCpGMEMwbm4taWZNRUE&usp=sharing
 
Sürekli dostum şeklinde hitap etmeniz hiç hoş değil be yavrum.

Yardımcı olmak isterim ama anlattıklarınız dosyalarınızı anlamak ve birleştirmek için zaman harcamak gerek. Şu an pek zamanım yok. Arkadaşlar yardımcı olacaklardır, olmazsa yarın tekrar bakarım.
 
Bu dost kelimesi mi sorun yoksa başka bir şey mi? =)
Şu zamanda çıkarsızca birşeyler paylaşılabilinen gercekten hoş bir ortam burası ve yardımlasma gıdın su fonksıyona bakın sunu soyle yapın seklınde degıl herkes bırılerının dosyasını ındırıp uzerınde zaman harcayıp paylasıyor. bu gercekten saygı duyulası bısey. bu sekılde cıkarsızca bırbırıne yardım eden ınsanlar bana gercekten yakın gelıyor ve bu sekılde hıtap etmem anormal olmasa gerek. tabı bu dısarıdan işini yaptırmak için yapılan yalaka ve bayagı bır davranıs gıbı de duruyor olabılır.

Gercekten yardımlarınız için teşekkür ederim, yanlış değerlendirmişsiniz durumu ama sorun değil.
 
Evet dostum kelimesinden pek haz etmem. Size ne kadar yakın geliyorsa bana da o kadar samimiyetten uzak bir kelime gibi geliyor.

Her neyse... önceki mesajımda da belirttiğim gibi; anlattıklarınızı ve dosyayı bağdaştıramadım. Bu sebeple yardımcı olamayacağım.

İyi günler.
 
İlginiz için çok teşekkür ederim gerçekten ilk yazdığınız kodla çok yardımcı oldunuz zamanınızı ve bilginizi paylaştığınız için tekrar teşekkür ederim. Bu konuyu çok aratmıştım ama her sayfayı kendi içinde birleştiren bir makro bulamamıştım, umarım başkalarına da faydalı bir araç olur.
İyi günler.
 
Tekrar merhabalar,

Konuyla ilgili bazı derlemeler yaptım. aslında tek tuşla tüm sayfalara uygulamayı istediğim düzenleme işlemlerini her sayfaya tuş koyarak yapmaya çalıştım. bu benim işimi görüyor geliştirmek veya değiştirmek gereken şeyler olabilir.
ama dediğim gibi bu benim işimi görüyor. Herkese yardımları için teşekkür ediyorum.

https://drive.google.com/folderview?id=0B4AeEngVSCpGVU0wVXNSVjJWNjA&usp=sharing
 
Peki Sn. burcin_end_muh.

İyi çalışmalar.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst