farklı çalışma kitabını birleştirme

[tahsinanarat]

veyisefendi adlı arkadaşımızın isteği üzerine evelce bu siteden temin ettiğim farklı çalışma kitabını bir araya toplayan dosya ektedir.


C:\DOSYALAR klasörü oluşturup aktarmak istediğiniz dosyalarınızı bu klasör altına yerleştirdikten sonra örnek dosyadaki makroyu çalıştırın. Umarım faydası olur.
DOSYA İSİMLERİNİN SAYI VEYA METİN OLABİLİR
A2 DE DİZİN ADI , B2 DEN AŞAĞIYA DOĞRU DİZİNDEKİ DOSYA İSİMLERİNİ YAZMANIZ GEREKİYOR (C:\DOSYALAR gibi)
Sub DİZİNDEKİ_DOSYALARI_AKTAR()
On Error Resume Next
Application.ScreenUpdating = False
Dim AKTARILACAK_DOSYA As Workbook
Dim ANA_DOSYA As Workbook
Dim DOSYA_YOLU As String
Set ANA_DOSYA = ThisWorkbook
Set SAYFA = ANA_DOSYA.Sheets("KRİTER")
Application.DisplayAlerts = False 'Önceki dosyaları siler
While Worksheets.Count > 1
Sheets(2).Delete
Wend
Application.DisplayAlerts = True
SAYFA.Select
DOSYA_YOLU = [A2]
If [A2] = "" Then
MsgBox "Lütfen dizin adını giriniz !", vbCritical, "Dikkat !"
[A2].Select
Exit Sub: End If

If WorksheetFunction.CountA([B:B]) = 1 Then
MsgBox "Lütfen dosya adı giriniz !", vbCritical, "Dikkat !"
[C2].Select
Exit Sub: End If
For X = ANA_DOSYA.Sheets.Count To 2 Step -1
Application.DisplayAlerts = False
Sheets(X).Delete
Application.DisplayAlerts = True
Next
If CreateObject("Scripting.FileSystemObject").GetFolder(DOSYA_YOLU).Files.Count = 0 Then GoTo Son
For X = 2 To [B65536].End(3).Row
DOSYA_VARMI = Dir(DOSYA_YOLU & "\" & SAYFA.Cells(X, 2) & ".xls")
If DOSYA_VARMI <> "" Then
Workbooks.Open (DOSYA_YOLU & "\" & SAYFA.Cells(X, 2) & ".xls")
Set AKTARILACAK_DOSYA = ActiveWorkbook
AKTARILACAK_DOSYA.Sheets(1).Copy After:=ANA_DOSYA.Sheets(ANA_DOSYA.Sheets.Count)
ActiveSheet.Name = AKTARILACAK_DOSYA.Name
AKTARILACAK_DOSYA.Close False
Set AKTARILACAK_DOSYA = Nothing
End If
Next

SAYFA.Select
[A1].Select
Set ANA_DOSYA = Nothing
Set SAYFA = Nothing
Application.ScreenUpdating = True
MsgBox "Veriler aktarılmıştır.", vbInformation
Exit Sub
Son:
[A1].Select
Set ANA_DOSYA = Nothing
Set SAYFA = Nothing
Application.ScreenUpdating = True
MsgBox "Veri aktarılacak dosya bulunamamıştır !", vbExclamation, "Dikkat !"
End Sub

 

[S.Yiğit]

Sn tahsinanarat

Elbette faydalı bir çalışma, Benimde Arşivimde bulunuyor. Hatta Bir çalışma kitabının içinde bulunan birden fazla sayfayı birleştirmek içinde sizden yardım almıştım.. Paylaşım için Tşkler..

 

[veyisefendi]

Sn Tahsinanarat,
Paylaşımlarınız ve ilginiz için teşekkür ederim.
Saygılarımla

 

[muzzymania]

arkadaslar daha farklı yerlere de yazdım fakat cevap alamadım ;

bu macro geliştirilerek acaba her sayfadaki veriler alt alta koyulabilirmi, yardımcı olabilirmisiniz?

 

[tahsinanarat]

Çalışma kitaplarındaki bütün sahifeleri almak için

Modüldeki kodun aşağıdaki satırda bulunan sheets(1) yazılı yeri Worksheets olarak değiştirin. Not. birleştireceğiniz dosya içerisindeki sayfa isimlerinin farklı olması gerekli, aynı isimle varsa birini alır. ayrıca her çalışma kitabının birinci sayfa ismi çalışma kitabı ismini verecektir.
AKTARILACAK_DOSYA.sheets(1).Copy After:=ANA_DOSYA.Sheets(ANA_DOSYA.Sheets.Count)

AKTARILACAK_DOSYA.Worksheets.Copy After:=ANA_DOSYA.Sheets(ANA_DOSYA.Sheets.Count)

şeklinde değiştirip ilk sayfalar değilde bütün sayfaları tek kitapta toplayabilirsiniz.
Eğer sayfalardaki formatlarınız aydı değerde olup, tek sayfada alt alta getirmek isterseniz

Private Sub Workbook_Open()
Application.ScreenUpdating = False
Sheets("Sayfa4").Select 'birleştirmek istediğiniz sayfa
Range("A2:Z65536").ClearContents
For i = 1 To Sheets.Count - 1
SonSatır = Sheets(i).[A65536].End(3).Row
Satır = [A65536].End(3).Row + 1
Sheets(i).Range("A2:Z" & SonSatır).Copy Range("A" & Satır)
Next i
SonSatır = [A65536].End(3).Row
Range("A2:Z" & SonSatır).Sort Key1:=[Z2], order1:=xlAscending
End Sub

 

[muzzymania]

öncelikle cevabınız için teşekkür ederim fakat sayfalar aynı boyut değil ama ilk 500 satır alınıp sıralama yapılarak sorun çözülebilir fakat bu macroda sadece ilk 4 satır alınıyor hangi alanda değişiklik yaparsam ilk 500 satırı alır acaba ?macro konusunda acemi olduğum için anlayamadım yardımlarınız için sonsuz minnettarım. Kolay gelsin

 

[avaca]

İlaç gibi geldi bu makro

 

[karakayalı]

bütün sayfaları tek bir calısma kitabında toplamak icin gerekli kodu calıstıramadım..yardımcı olursanız sevinirim...kolay gelsin

 

[karakayalı]

Sub Workbook_Open()
Application.ScreenUpdating = False
Sheets("Sayfa4").Select 'birleştirmek istediğiniz sayfa
Range("A2:Z65536").ClearContents
For i = 1 To Sheets.Count - 1
SonSatır = Sheets(i).[A65536].End(3).Row
Satır = [A65536].End(3).Row + 1
Sheets(i).Range("A2:Z" & SonSatır).Copy Range("A" & Satır)
Next i
SonSatır = [A65536].End(3).Row
Range("A2:Z" & SonSatır).Sort Key1:=[Z2], order1:=xlAscending
End Sub


şeklinde yazılıp ve sayfa4 diye sayfa acılması halaınde kod calışıyor...