klasördeki tüm excel dosyalarını bir excele almak

[microaim]

merhaba arkadaşlar;

Örneğin masaüstünde excel diye bir klasörümüz var ve bunun içinde 50 tane excel çalışma kitabı var. bu 50 tane excelin 1.sayfalarını tek bir seferde üzerinde çalıştığım excele aldırmam mümkün mü? üzerinde çalıştığım kitapta masaüstündeki excel klasörü kadar sayfa oluşturacak ve hepsinin ilk sayfasını alacak...

şimdiden teşekkürler...

 

[alibaskan]

Ekteki dosyada yapmaya çalıştım bende çalışıyor. Masaüstüne Yeni Klasör açıp onun içindeki excel dosyalarını aktif çalışma kitapına aldırdım. Siz kendi masaüstünüzdeki klasör olarak dosya yolunu koddan düzeltin. Ayrıca sayfaları taşıyacak şekilde kodları yazdım. Eğer kaynak dosyada sayfalarım dursun isterseniz koddaki move kelimesini Copy olarak değiştirebilirsiniz.

 

[alibaskan]

Çözüm önerimin işinize yarayıp yaramadığı konusunda bilgi verir misiniz?

 

[microaim]

sayın alibaskan;
öncelikle bu güzel çalışmana geç cevap yazdığım için (iş yoğunluğundan dolayı ancak bakabildim) çok özür dilerim.
çalışma gerçekten tam istediğim gibi olmuş ve çok iyi çalışıyor. ellerine sağlık.
çok teşekkür ederim. iyi çalışmalar...

 

[tuncismet]

Sayın:alibaskan,
Dosya boş,bunu örnek bir klasörde gösterebilirmisiniz? Teşekkürler

 

[alibaskan]

Sn.Tunçismet, Sn.Microaim'in sorusuna göre zaten ana dosya boş olmalı. Masaüstündeki Yeni Klasörün içindeki excel dosyalarının ilk sayfalarını bu dosyaya ekler. Siz başka klasörden aktarmak isterseniz kodların içinden klasörün yolunu düzelterek bunu yapabilirsiniz.

 

[ildizim]

ACİL YARDIM
EKLİ KODU CSV VE TXT DOSYALARI İÇİNDE ÇALIŞACAK ŞEKİLDE OLMAK ÜZERE İKİ AYRI VERSİYONUNUDA YAZABİLİRMİSİNİZ.

Private Sub Workbook_Open()
Dim Bukitap As Workbook
Dim Okitap As Workbook
Dim i As Long
Application.ScreenUpdating = False
With Application.FileSearch
.NewSearch
.LookIn = "C:\Documents and Settings\abaskan\Desktop\Yeni Klasör"
.SearchSubFolders = False
.FileType = msoFileTypeExcelWorkbooks
If .Execute() > 0 Then
Set Bukitap = ThisWorkbook
For i = .FoundFiles.Count To 1 Step -1
Set Okitap = Workbooks.Open(.FoundFiles(i))
Okitap.Sheets(1).Move After:=Bukitap.Sheets("Genel")
Next i
End If
End With
Application.ScreenUpdating = True
End Sub

 

[ildizim]

yardım lutfen

 

[ildizim]

arkadaşlar yardımıznızı rica ediyorum

 

[bulentkars]

Aşağıdaki Makroyu modüle yapıştırn olacak.

Sub Kıtap_Kopyala()



Dim say As Long Dim say2 As Long
Dim Dosya As String

Dosya = Dir("C:\EXCELWEB\*.XLS") ' klasör yerı belırlenır.

Do Until Dosya = ""
Workbooks.Open "C:\EXCELWEB\" & Dosya ' klasör yeri belirlenir
say = WorksheetFunction.CountA(Range("e:e")) ' saydırılacak sutun adı yazılır.
say2 = WorksheetFunction.CountA(ThisWorkbook.Worksheets("SAYFA1").Range("e:e")) + 1 ' saydırılacak sütün adı yazılır
Range("A1:e" & say).Copy ThisWorkbook.Worksheets("SAYFA1").Range("A" & say2) ' kopyalacak aralık belırlenır

Dosya = Dir
ActiveWorkbook.Close False
Loop
End Sub

 

[ersoyalan]

Merhaba,

Ekli dosya işinizi görecektir.

iyi çalışmalar,

E.ALAN