• DİKKAT

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

Excel Sayfalarını Birleştirme sorunu

H

htsumer

Altın Üye
Altın Üye
Katılım
7 Eylül 2004
Mesajlar
975
Excel Vers. ve Dili
Excel-2003
AŞağıdaki kod ile 30 dan fazla excel dosylarını tek excele birleştiriyorum.

30 dosyada 2 adet sayfa var
birinci sayfanın adı ankara (her dosyada farklı isim),
ikinci sayfanın adı YENİ KAYIT (30 sayfada da aynı isim)geçiyor.

Aşağıdaki kod ile 30 adeti birleştiriyor ama YENİ KAYIT sayfalarını birleştirmiyor.

Kod: 
Sub MergeWBooks()
Dim MyTitle As String, MyPath As String, MyFile As String
Dim i As Byte, nWB As Byte, nSh As Byte
Dim ObjFolder As Object
MyTitle = "Lütfen sayfaları birleştirilecek dosyaların olduğu yolu seçin !"
Set ObjFolder = CreateObject("Shell.Application").BrowseForFolder(0, MyTitle, 0, 0)
If Not ObjFolder Is Nothing Then
MyPath = ObjFolder.Items.Item.Path
MyFile = Dir(MyPath & Application.PathSeparator & "*.xls", vbDirectory)
Application.ScreenUpdating = False
Do While MyFile <> ""
If MyFile = ThisWorkbook.Name Then GoTo ResumeSub:
nWB = nWB + 1
Workbooks.Open MyPath & Application.PathSeparator & MyFile
For i = 1 To Worksheets.Count
nSh = nSh + 1
Sheets(i).Copy After:=ThisWorkbook.Sheets(Worksheets.Count)
Next
Workbooks(MyFile).Close
ResumeSub:
MyFile = Dir
Loop
Set ObjFolder = Nothing
MsgBox "Toplam " & nWB & " adet kitaptan toplam " & nSh & " adet sayfa birleştirilmiştir !", vbInformation, "Rapor !"
End If
Application.ScreenUpdating = True
End Sub
 
Dediğiniz denedim fakat bu sefer her dosyadaki birinci sayfayı 2 kere birleştirdi.

30 Adet dosyada bulunan birinci sayfaları birleştiriyor ama 30 dosyadaki ikinci sayfaları birleştirmiyor
30 sayfadaki her iki sayfayı birden birleştirsin istedim ama olmuyor..

30 dosyadaki iher ikinci sayfa aynı ad'da olduğu içinmi acaba..
 
Kod: 
For i = 1 To Worksheets.Count
nSh = nSh + 1

kodunu önce çalıştırdım birinci sayfaları aldırdım
daha sonra

Kod: 
For i = 2 To Worksheets.Count
nSh = nSh + 1

2 yaparak diğer sayfayı aldırdım..Acemice halloldu ..olsun sonuç oldu..

Teşekkür ederim yardımınız için
 
birde bunu denermisiniz.

Sub MergeWBooks()
Sayfa_Adı = ActiveSheet.Name
Dim MyTitle As String, MyPath As String, MyFile As String
Dim i As Byte, nWB As Byte, nSh As Byte
Dim ObjFolder As Object
MyTitle = "Lütfen sayfaları birleştirilecek dosyaların olduğu yolu seçin !"
Set ObjFolder = CreateObject("Shell.Application").browseforfolder(0, MyTitle, 0, 0)
If Not ObjFolder Is Nothing Then
MyPath = ObjFolder.Items.Item.path
MyFile = Dir(MyPath & Application.PathSeparator & "*.xls", vbDirectory)
Application.ScreenUpdating = False
Do While MyFile <> ""
If MyFile = ThisWorkbook.Name Then GoTo ResumeSub:
nWB = nWB + 1
Workbooks.Open MyPath & Application.PathSeparator & MyFile
Dim myArray() As Variant
For i = 1 To ActiveWorkbook.Sheets.Count
ReDim Preserve myArray(i - 1)
myArray(i - 1) = i
nSh = nSh + 1
Next i
Sheets(myArray).Select
Sheets(myArray).Copy Before:=ThisWorkbook.Sheets(1)
Workbooks(MyFile).Close
ResumeSub:
MyFile = Dir
Loop
Set ObjFolder = Nothing
Sheets(Sayfa_Adı).Select
MsgBox "Toplam " & nWB & " adet kitaptan toplam " & nSh & " adet sayfa birleştirilmiştir !", vbInformation, "Rapor !"
End If
Application.ScreenUpdating = True
End Sub
Genişletmek için tıkla ...
 
Henüz yeni deneme imkanım oldu..

Harika Halit bey..
Saat gibi çalıştı çok teşekkür ederim eline sağlık..
 
Arkadaşlar benimde böyle bir sorunum var verdiğiniz bu kodu nasıl uyguluyoruz yardımcı olurmusunuz
 
bu kodlarla sayfaları birleştiriyorum tşk.

Fakat her satırda b kolonu resim var.
Filtre uyguladığım an filitre dışında ki resimleri üst üste topluyor.
Buna bir çare var mı?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst