Dosya birleştirme kodunda değişiklik hk.

feridici_genc · 11 Ocak 2016

Hayırlı günler,
Halit bey'in paylaştığı kodda değişiklik yapmaya çalıştım fakat işler hepten karıştı.
Eskiden yanlışta olsa alt alta yazan kodlar şimdi birbirlerinin üstüne yazmaya başladı. ADO çok aşırı yavaş çalıştı. Farklı bir yöntem denemek istedim.
Yapmaya çalıştığım şey şu:
Aşağıda adresi yazılan klasör içinde bulunan dosya isimleri sayı ile başlayan tüm dosyaların B sütunu, E sütunu, I sütunu, K sütunu ve M sütunlarını tek bir sayfada toplamak istiyorum.
Bir de farklı kod denemelerimde hep karşıma çıktı aşağıdaki hata.
Her dosya için Continue demem gerekiyor. Bu hatayı nasıl giderebilirim?

Kod:

Sub aktar2()
Kaynak = "C:\Users\ocop0909\Desktop\Yeni klasör\YENİ"

Application.DisplayAlerts = False

Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If ThisWorkbook.Name <> Dosya.Name Then
deg = "'" & Kaynak & "\" & "[" & Dosya.Name & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "A").End(3).Row + 1
Cells(sat, "B") = ExecuteExcel4Macro(deg & 2 & "C" & 2)
Cells(sat, "E") = ExecuteExcel4Macro(deg & 4 & "C" & 5)
Cells(sat, "I") = ExecuteExcel4Macro(deg & 7 & "C" & 9)
Cells(sat, "K") = ExecuteExcel4Macro(deg & 10 & "C" & 11)
Cells(sat, "M") = ExecuteExcel4Macro(deg & 13 & "C" & 13)

End If
Next
Application.ScreenUpdating = True

MsgBox "işlem tamam"

End Sub

feridici_genc · 11 Ocak 2016

Dostlar bir el atabilirmisiniz?

PLİNT · 12 Ocak 2016

Merhaba
Kodlarınızdaki yolu şöyle denedim hata vermedi
(Her dosyanın 5 hücresinden veri geliyor)

Kod:

Kaynak = ThisWorkbook.Path & "\YENİ"

son satır için: "B" sütunu olması gerek gibi ("a" sütunundaki durumu bilmiyoruz)

Kod:

sat = Cells([COLOR="Red"]Rows.Count, "B")[/COLOR].End(3).Row + 1

Dosya isimleri Sayı ile başlayanlar içinde aşağıdaki kırmızı bölümler

Kod:

Sub aktar2()
Kaynak = "C:\Users\ocop0909\Desktop\Yeni klasör\YENİ"
 
Application.DisplayAlerts = False

Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If ThisWorkbook.Name <> dosya.Name Then
If IsNumeric(Left(dosya.Name, 1)) = True Then
deg = "'" & Kaynak & "\" & "[" & dosya.Name & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi
sat = Cells(Rows.Count, "B").End(3).Row + 1
Cells(sat, "B") = ExecuteExcel4Macro(deg & 2 & "C" & 2)
Cells(sat, "E") = ExecuteExcel4Macro(deg & 4 & "C" & 5)
Cells(sat, "I") = ExecuteExcel4Macro(deg & 7 & "C" & 9)
Cells(sat, "K") = ExecuteExcel4Macro(deg & 10 & "C" & 11)
Cells(sat, "M") = ExecuteExcel4Macro(deg & 13 & "C" & 13)
End If
End If
Next
Application.ScreenUpdating = True

MsgBox "işlem tamam"
End Sub

Yukarıdaki belirttiğiniz hata oluşmadı.
Bir örnek klasör hazırlayıp eklerseniz daha iyi sonuç alınabilir

feridici_genc · 12 Ocak 2016

Hocam ben şu yazdıklarınız için yardım istiyorum

'....
'...
bu alana ne yazılacak

PLİNT · 12 Ocak 2016

O bölümlerde değişiklik gerekmediği için eski bölümleri yazarsınız diye o şekilde yazmıştım.
Yukarıdaki değişen kodlar gibi kullanın

feridici_genc · 12 Ocak 2016

yukarıdaki kodlar o işe yaramıyor üstadım.
Bahsettiğim stünları getirmiyor. sadece ilk hücrelerini getirim işlemi bitiiriyor.

feridici_genc · 12 Ocak 2016

şöyle anlatayım,
1.dosya B, E, I, K, M sütunları
2.dosya B, E, I, K, M sütunları
3.dosya B, E, I, K, M sütunları
4.dosya B, E, I, K, M sütunları
yani alt alta. bahsedilen sütunlar nerede bitiyorsa diğer dosyaya geçecek..

PLİNT · 12 Ocak 2016

feridici_genc' Alıntı:
yukarıdaki kodlar o işe yaramıyor üstadım.
Bahsettiğim stünları getirmiyor. sadece ilk hücrelerini getirim işlemi bitiiriyor.

Zaten yukarıda 5 hücre aldığını belirtmiştim,
döngüyle alt hücrelerdende alınabilir ama "macro4" le toplu alamazsınız, yine en hızlısı ADO olacaktır.

feridici_genc · 12 Ocak 2016

ADO neredeyse 33 DK. sürdü.
Bu yöntemi denemek istemiştim.

feridici_genc · 12 Ocak 2016

Sayın PLİNT,
ben kodların bir kısmını çözdüm aslında. sadece kaynaktan kopyalayıp hedefe yapıştırmak kaldı.

Kod:

Sub aktar2()
Kaynak = "C:\Users\ocop0909\Desktop\Yeni klasör\YENİ"
 
Application.DisplayAlerts = False

Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
For Each dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Kaynak).Files
If ThisWorkbook.Name <> dosya.Name Then
If IsNumeric(Left(dosya.Name, 1)) = True Then
deg = "'" & Kaynak & "\" & "[" & dosya.Name & "]" & "Sayfa1" & "'!R" '//Veri alınacak dosyalardaki sayfa isimi

[COLOR="Red"].........[/COLOR]


End If
End If
Next
Application.ScreenUpdating = True

MsgBox "işlem tamam"
End Sub

PLİNT · 12 Ocak 2016

Merhaba
Ek dosyayı incelermisiniz, http://www.dosya.tc/server6/9jrynr/klasor.zip.html

feridici_genc · 12 Ocak 2016

Hay Allah razı olsun sizlerden.
Bu yöntem ile veri alma işlemi 16 saniye sürdü ama ADO ile 33 Dk. sürmüştü.
Son olarak dosya yolunu sabitleyebilir miyiz yada açılan pencerede ctrl basarak istediğimiz dosyaları seçebilir miyiz?
Teşekkür ederim.

PLİNT · 12 Ocak 2016

feridici_genc' Alıntı:
Son olarak dosya yolunu sabitleyebilir miyiz yada açılan pencerede ctrl basarak istediğimiz dosyaları seçebilir miyiz?

Merhaba
Dosya yolunu sabitlemek için; bir sayfaya veri alınacak dosyalar listelenerek kodlar değiştirilebilr gerekirse yapmaya çalışalım.
Seçerek veri almak için aşağıdaki gibi deneyin;

Kod:

Private Sub CommandButton1_Click()
Dim seç, sat, sat2 As Long
Dim Aç As Application
Dim hz As Workbook
With Application.FileDialog(msoFileDialogOpen)
.AllowMultiSelect = True
.Show
If .SelectedItems.Count = 0 Then Exit Sub
For seç = 1 To .SelectedItems.Count
Set Aç = New Excel.Application
Aç.Workbooks.Open .SelectedItems(seç)
Set hz = Aç.Workbooks(Dir(.SelectedItems(seç)))
sat = Cells(Rows.Count, "B").End(3).Row + 1
sat2 = hz.Sheets("Sayfa1").Cells(Rows.Count, "B").End(3).Row
Range("B" & sat & ":B" & sat + sat2 - 2).Value = hz.Sheets("Sayfa1").Range("B2:B" & sat2).Value
Range("E" & sat & ":E" & sat + sat2 - 2).Value = hz.Sheets("Sayfa1").Range("E2:E" & sat2).Value
Range("I" & sat & ":I" & sat + sat2 - 2).Value = hz.Sheets("Sayfa1").Range("I2:I" & sat2).Value
Range("K" & sat & ":K" & sat + sat2 - 2).Value = hz.Sheets("Sayfa1").Range("K2:K" & sat2).Value
Range("M" & sat & ":M" & sat + sat2 - 2).Value = hz.Sheets("Sayfa1").Range("M2:M" & sat2).Value
Cells(sat, "b").Select
hz.Close SaveChanges:=False
Aç.Quit
Set Aç = Nothing: Set hz = Nothing
Next seç
End With
End Sub

Bu arada yukarıdaki dosyada bulunan kodlar ilk mesajınızda istediğiniz gibi
adının başında rakam olan dosyalardan veri alacak şekildedir. Bu kodlar ise
(seçtiğiniz takdirde) dosya adında rakam olsun olmasın; değerleri getirecektir.

feridici_genc · 13 Ocak 2016

Üstad teşekkür ederim. çok sağol.