birden fazla exceldeki verileri tek bir excel dosyasında toplama

[betoncu]

Bir sorum daha olacaktı:
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya

Kodunu uygulayınca örnek dosyaların isimleri sadece 3. ve 5. satır A hücresinde gözüküyor. Bunu değer olan satırlarda gösterebilirmiyiz?

 

[betoncu]

Aynı zamanda deneme dosyasında (verilerin çekileceği dosyada) veriler 2. satırdan itibaren yazdırılıyor. Bu 2. satırdan yazdırmaya başlama kodu hangisidir acaba? Kısaca 2. satır yerine mesela 10. satırdan yazdırma kodu nasıldır acaba?

 

[numan şamil]

Bir sorum daha olacaktı:
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya

Kodunu uygulayınca örnek dosyaların isimleri sadece 3. ve 5. satır A hücresinde gözüküyor. Bunu değer olan satırlarda gösterebilirmiyiz?

Kodları Şu şekilde denermisiniz

Worksheets(ActiveSheet.Name).Cells(sat, "b") = ExecuteExcel4Macro(deg & 3 & "C" & 3)
Worksheets(ActiveSheet.Name).Cells(sat, "c") = ExecuteExcel4Macro(deg & 3 & "C" & 4)
Worksheets(ActiveSheet.Name).Cells(sat, "d") = ExecuteExcel4Macro(deg & 3 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "e") = ExecuteExcel4Macro(deg & 3 & "C" & 6)
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya
sat = sat + 1
Worksheets(ActiveSheet.Name).Cells(sat, "b") = ExecuteExcel4Macro(deg & 4 & "C" & 3)
Worksheets(ActiveSheet.Name).Cells(sat, "c") = ExecuteExcel4Macro(deg & 4 & "C" & 4)
Worksheets(ActiveSheet.Name).Cells(sat, "d") = ExecuteExcel4Macro(deg & 4 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "e") = ExecuteExcel4Macro(deg & 4 & "C" & 6)
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya

Diğer sorunuzun cevabına gelince kodların gerçek sahibi Halit hocam umarım cevap verir

 

[betoncu]

Numan bey çok teşekkür ederim. Açıklamalarınız çok faydalı oldu.
Halit hocamdanda yardım bekliyoruz. Emeklerinize sağlık...

 

[halit3]

Aynı zamanda deneme dosyasında (verilerin çekileceği dosyada) veriler 2. satırdan itibaren yazdırılıyor. Bu 2. satırdan yazdırmaya başlama kodu hangisidir acaba? Kısaca 2. satır yerine mesela 10. satırdan yazdırma kodu nasıldır acaba?

Başlangıç satırı kodun bu bölümü:

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

Kırmızı yerin değerini arttırırsanız o kadar satırdan sonra veriler yazılacaktır.

 

[betoncu]

Başlangıç satırı kodun bu bölümü:

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

Kırmızı yerin değerini arttırırsanız o kadar satırdan sonra veriler yazılacaktır.

Halit bey kırmızı 1 yerine 9 koyunca örnek1 e ait veriler 10. satırdan başladı fakat bu sefer örnek 2 ye ait veriler 20. satırdan itibaren yazılmaya başlandı.
Örnek2 ye ait veriler örnek1in bittiği son satırdan hemen sonra nasıl başlatılır acaba?

Kodun İlgili Kısmı:
sat = Cells(Rows.Count, "d").End(3).Row + 9
sayfaadi = "Sayfa1"
'Cells(sat, "A").Value = Klasor & "\" & Dosya
deg = "'" & Klasor & "\[" & Dosya & "]" & sayfaadi & "'!R"

Worksheets(ActiveSheet.Name).Cells(sat, "b") = ExecuteExcel4Macro(deg & 3 & "C" & 3)
Worksheets(ActiveSheet.Name).Cells(sat, "c") = ExecuteExcel4Macro(deg & 3 & "C" & 4)
Worksheets(ActiveSheet.Name).Cells(sat, "d") = ExecuteExcel4Macro(deg & 3 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "e") = ExecuteExcel4Macro(deg & 3 & "C" & 6)
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya
sat = sat + 1
Worksheets(ActiveSheet.Name).Cells(sat, "b") = ExecuteExcel4Macro(deg & 4 & "C" & 3)
Worksheets(ActiveSheet.Name).Cells(sat, "c") = ExecuteExcel4Macro(deg & 4 & "C" & 4)
Worksheets(ActiveSheet.Name).Cells(sat, "d") = ExecuteExcel4Macro(deg & 4 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "e") = ExecuteExcel4Macro(deg & 4 & "C" & 6)
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya

 

[halit3]

Halit bey kırmızı 1 yerine 9 koyunca örnek1 e ait veriler 10. satırdan başladı fakat bu sefer örnek 2 ye ait veriler 20. satırdan itibaren yazılmaya başlandı.
Örnek2 ye ait veriler örnek1in bittiği son satırdan hemen sonra nasıl başlatılır acaba?

Kodun İlgili Kısmı:
sat = Cells(Rows.Count, "d").End(3).Row + 9
sayfaadi = "Sayfa1"
'Cells(sat, "A").Value = Klasor & "\" & Dosya
deg = "'" & Klasor & "\[" & Dosya & "]" & sayfaadi & "'!R"

Worksheets(ActiveSheet.Name).Cells(sat, "b") = ExecuteExcel4Macro(deg & 3 & "C" & 3)
Worksheets(ActiveSheet.Name).Cells(sat, "c") = ExecuteExcel4Macro(deg & 3 & "C" & 4)
Worksheets(ActiveSheet.Name).Cells(sat, "d") = ExecuteExcel4Macro(deg & 3 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "e") = ExecuteExcel4Macro(deg & 3 & "C" & 6)
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya
sat = sat + 1
Worksheets(ActiveSheet.Name).Cells(sat, "b") = ExecuteExcel4Macro(deg & 4 & "C" & 3)
Worksheets(ActiveSheet.Name).Cells(sat, "c") = ExecuteExcel4Macro(deg & 4 & "C" & 4)
Worksheets(ActiveSheet.Name).Cells(sat, "d") = ExecuteExcel4Macro(deg & 4 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "e") = ExecuteExcel4Macro(deg & 4 & "C" & 6)
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya

Yukarıdaki mesajımda söylemiştim ben dosyanıza vakıf değilim.İşlemleri bilmek dosyanıza hakim olmak anlamına gelmesin bu konular baya zahmetli ve meşakkat isteyen konular.

Başka mesaj yazmıyacağım.

kod:

Dim sat As String
Private Sub CommandButton1_Click()
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Kaynak Dosyaları İçeren Klasörü Seçin", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
[A2:I65000] = ""
sat = 9
Liste (Kaynak)
Set Klasor = Nothing
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
End Sub
Private Sub Liste(yol As String)
Dim fL As Object, fs As Object, f As Object, j As Long, n As Long
Set fL = CreateObject("Scripting.FileSystemObject").GetFolder(yol).subfolders
Set fs = CreateObject("Scripting.FileSystemObject").GetFolder(yol).Files
If Right(yol, 1) <> "\" Then ekle = "\"
On Error Resume Next
For Each Dosya In fs
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
sayfaadi = "Sayfa1"
deg = "'" & yol & ekle & "[" & Dosya.Name & "]" & sayfaadi & "'!R"
If ExecuteExcel4Macro(deg & 3 & "C" & 3) <> "" Then
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya.Name
Worksheets(ActiveSheet.Name).Cells(sat, "b") = ExecuteExcel4Macro(deg & 3 & "C" & 3)
Worksheets(ActiveSheet.Name).Cells(sat, "c") = ExecuteExcel4Macro(deg & 3 & "C" & 4)
Worksheets(ActiveSheet.Name).Cells(sat, "d") = ExecuteExcel4Macro(deg & 3 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "e") = ExecuteExcel4Macro(deg & 3 & "C" & 6)
sat = Cells(Rows.Count, "b").End(3).Row + 1
End If
If ExecuteExcel4Macro(deg & 4 & "C" & 3) <> "" Then
Worksheets(ActiveSheet.Name).Cells(sat, "f") = ExecuteExcel4Macro(deg & 4 & "C" & 3)
Worksheets(ActiveSheet.Name).Cells(sat, "g") = ExecuteExcel4Macro(deg & 4 & "C" & 4)
Worksheets(ActiveSheet.Name).Cells(sat, "h") = ExecuteExcel4Macro(deg & 4 & "C" & 5)
Worksheets(ActiveSheet.Name).Cells(sat, "ı") = ExecuteExcel4Macro(deg & 4 & "C" & 6)
Worksheets(ActiveSheet.Name).Cells(sat, "a") = Dosya.Name
sat = Cells(Rows.Count, "f").End(3).Row + 1
End If
End If

Next
On Error GoTo sonraki
For Each f In fL
Liste (f.Path)
sonraki:
Next
Set fL = Nothing
End Sub

 

[betoncu]

Halit bey çok teşekkür ederim. Sizin ve diğer arkadaşların sayesinde faydalı bilgiler edindim

 

[numan şamil]

Halit hocam Müsadenizle
kodlarda ufak bir değişiklik yaptım

 

[syuksel2]

merhaba,

elimde anket için hazırlanmış standart bir form var. Yapmak istediğim şey bu excellerden verileri çekip bi rapor hazırlamak istiyorum. yukarıdaki cevaplardan uğraştım ama çözemedim.. şimdiden yardımlarınız için çok teşekkür ederim

merhaba
Bütün dosyalarda veri çekeceğiniz hücreler standart ise ve veri çekilecek dosyalar ile veriyi aktaracağınız dosya ayrı klosörde olmalıdır

ekteki dosyayı inceleyiniz veri çekeceğiniz hücrelere göre uyarlamaya çalışınız
Aktar butonuna basınız