Örnek Dosyadaki Makroda Düzeltme

[cengizyener]

Arkadaşlar merhabalar,

4 tane excel dosyası yükledim. verilerim "TEKLİ DOSYA" isimleri ile 3 excel dosyasında kayıtlı hepsini "TOPLU DOSYA" ismindeki dosyada toplamak istiyorum. Örnek kod buldum fakat kodda bazı düzeltmeler yaptım. Ben tüm dosyaların "Sayfa1" sayfalarındaki verileri almak istiyorum ve alabiliyorum fakat sorun şu ki "Sayfa1" deki verileri ilgili dosyada ki sayfa sayısı kadar tekrar almaktadır. Bu kodu nasıl düzeltmem gerekir örnek kod aşağıda yer almaktadır.

Sub Birlestir()


Sheets("Yeni").Select
Range("B4:M65536").ClearContents

Dosyalarin_bulundugu_klasoru_sec

Application.ScreenUpdating = False

If [BM1] = "" Then End

Dim t, dosyasay As Integer
Dim fso As Object, f As Object, dosya As String, kaynak As String, fls As Object
Dim sonsatir As Long, sonsat1 As Long, sonsat2 As Long, sh As Worksheet, liste()
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder([BM1]).Files

dosyasay = 0

ThisWorkbook.Activate
ThisWorkbook.Sheets("Yeni").Select

For Each fls In f
If fso.GetExtensionName(fls) = "xlsx" Then

If Workbooks.Open(fls).ReadOnly = True Then Workbooks(fls.Name).Close False

For Each sh In Workbooks(fls.Name).Worksheets
sonsat1 = Sheets("Sayfa1").Cells(65536, "B").End(xlUp).Row
If sonsat1 > 1 Then
liste = Sheets("Sayfa1").Range("B1:M" & sonsat1).Value
sonsat2 = ThisWorkbook.Sheets("Yeni").Cells(65536, "B").End(xlUp).Row + 1
ThisWorkbook.Sheets("Yeni").Range("B" & sonsat2).Resize(UBound(liste), 12) = liste
Erase liste
End If
Next sh
dosyasay = dosyasay + 1
Workbooks(fls.Name).Close False
End If
Next fls
ThisWorkbook.Activate
ThisWorkbook.Sheets("Yeni").Select



Application.ScreenUpdating = True
MsgBox dosyasay & " adet dosyadaki bilgiler Programa aktarildi."


End Sub

Sub Dosyalarin_bulundugu_klasoru_sec()
Dim kaynak As String
[BM1].Clear
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Dosyalarin bulundugu Klasoru Secin", 50, &H0)
If Not Klasor Is Nothing Then
kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
[BM1] = kaynak

End If
End Sub

 

[cengizyener]

Güncelleme

Yukardaki sorunumu çözdüm fakat yukardaki kodda

Sub Dosyalarin_bulundugu_klasoru_sec()
Dim kaynak As String
[BM1].Clear
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Dosyalarin bulundugu Klasoru Secin", 50, &H0)
If Not Klasor Is Nothing Then
kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path
[BM1] = kaynak

End If
End Sub

bu kodda Klasör seçmemi istiyor fakat ben klasör seçmek yerine "C:\Users\User\Desktop\EXCEL\Yeni klasör\Deneme" bu dizindeki dosyaları almasını istiyorum bu kodda nasıl bir değişiklik yapmam lazım bir türlü bulamadım

 

[muhasebeciyiz]

Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Dosyalarin bulundugu Klasoru Secin", 50, &H0) If Not Klasor Is Nothing Then
Bu kısım, kullanıcının bir klasör seçmesini sağlayan kod bloğudur. Bu bloğu tamamen kaldırabilirsiniz.

Kaldırdığınız kod bloğunun yerine, sabit dizin yolunu bir değişkene atayın. Örneğin:
Dim kaynak As String
kaynak = "C:\Users\User\Desktop\EXCEL\Yeni klasör\Deneme"

 

[cengizyener]

Merhabalar,

Geri dönüşünüz için çok teşekkür ederim. Kodu revize ettim fakat aşağıdaki hatayı alıyorum şuan. Yardımcı olursanız çok sevinirim.

 

[cengizyener]

Merhabalar muhasebeciyiz,

kaynak = Klasor.SELF.Path 'Klasor.Items.Item.Path komutunu iptal edince veriler geldi. Yardımlarınız için çok teşekkür ederim sorunum çözüldü. İyi günler dilerim.