dosyaları istediğimiz sütünlara göre ucu uca eklemek

[kucukdunyam]

merhabalar, forumlardan yola çıkarak makroyu düzenlemeye çalıştım ancak sağlıklı çalıştıramadım. eklediğim dosya için bana yardımcı olabilirmisiniz.
Veri Al dosyasına (klasörün içindeki dosyalardaki verileri almak istiyorum) ilgili hücrelerin altına boşluk olmadan sıralasın istiyorum. ilk sütun için bunu yapıyor, ancak diğer sütunlar için de yaptırmak istiyorum, yardımlarınız için şimdiden teşekkür ederim.

 

[Ömer]

Merhaba,

Kodlardaki For y döngüsünü aşağıdaki gibi değiştirerek deneyin. Yeşil alanları pasif yaptım kırmızı alanları ilave ettim. Pasif yaptığım alanları neden kullandığınızı anlayamadım. Ayrıca veriler dosyasındaki excel çalışmalarında birleştirilmiş hücre kullanmasaydınız kod çok daha kısa olurdu. Birleştirilmiş hücreleri de neden kullandığınızı anlayamadım. Esasında döngü kurmayada gerek yok fakat ne istediğinizi tam olarak anlayamadığım için o kısmı bıraktım.

        For Y = 2 To Cells(65536, 1).End(3).Row
 
[COLOR=darkgreen]       'Data = Split(Cells(Y, 1), ";")[/COLOR]
[COLOR=darkgreen]       'Sütun = 1[/COLOR]
[COLOR=darkgreen]         'For Z = 0 To UBound(Data())[/COLOR]
[COLOR=darkgreen]         'If Sütun = 10 Then[/COLOR]
[COLOR=darkgreen]         'Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, Sütun) = CDate(Data(Z))[/COLOR]
[COLOR=darkgreen]         'Else[/COLOR]
[COLOR=darkgreen]         'Veri_Dosyası.Sheets("Sayfa1").Cells(Satır, Sütun) = Data(Z)[/COLOR]
 [COLOR=red]           With Veri_Dosyası.Sheets("Sayfa1")[/COLOR]
[COLOR=red]             .Cells(Satır, "A") = Cells(Y, "A")[/COLOR]
[COLOR=red]             .Cells(Satır, "B") = Cells(Y, "B")[/COLOR]
[COLOR=red]             .Cells(Satır, "C") = Cells(Y, "E")[/COLOR]
[COLOR=red]             .Cells(Satır, "D") = Cells(Y, "H")[/COLOR]
[COLOR=red]             .Cells(Satır, "E") = Cells(Y, "I")[/COLOR]
[COLOR=red]             .Cells(Satır, "H") = Cells(Y, "L")[/COLOR]
[COLOR=red]             .Cells(Satır, "I") = Cells(Y, "M")[/COLOR]
[COLOR=red]             .Cells(Satır, "J") = Cells(Y, "O")[/COLOR]
[COLOR=red]             .Cells(Satır, "K") = Cells(Y, "Q")[/COLOR]
[COLOR=red]             .Cells(Satır, "L") = Cells(Y, "R")[/COLOR]
[COLOR=red]         End With[/COLOR]
[COLOR=darkgreen]         'End If[/COLOR]
[COLOR=darkgreen]         'Sütun = Sütun + 1[/COLOR]
[COLOR=darkgreen]         'Next[/COLOR]
            Satır = Satır + 1
        Next

.

 

[kucukdunyam]

teşekkür ederim ömer bey, ben sayfanın biraz formatını değiştirdim. bir de birinci sütünü esas alıyor, yani birinci sütunda veri yoksa, diğer L sütünunu ve P sütünundaki verileri dikkate almıyor (mesela 3 nolu dosyadaki verileri almıyor) dosyamı yeniden ekledim tekrar yardımcı olabilirseniz çok sevinirim, teşekkürler.

 

[kucukdunyam]

tekrar teşekkür ederim. gerek kalmadı. bu örnekteki gibi bir bilgiye ihtiyaç olanlar için paylaşmak istiyorum.

Sub TÜM_VERİLERİ_AL()
Dim Klasör() As String, X As Integer, Y, S, T As Long, Z As Integer
Dim Veri_Dosyası As Workbook, Dosya As Object, Kaynak_Dosya As Workbook, Sayfa As Worksheet
Dim Dosya_Yolu As String, Satır As Long, Sütun As Byte, Data() As String
[g7] = ThisWorkbook.Path
On Error GoTo Son
Application.ScreenUpdating = False
Set Veri_Dosyası = ThisWorkbook
Veri_Dosyası.Sheets("Sayfa1").Range("A11:w65536").ClearContents
Dosya_Yolu = Veri_Dosyası.Path & "\" & "VERİLER"
If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo Son
For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)

For Y = 14 To Cells(65536, 1).End(3).Row 'alınacak verinin başladığı satır
Satır = Veri_Dosyası.Sheets("Sayfa1").Range("A65536").End(3).Row + 1 'aktarılacak sayfanın başlangıç satırı
With Veri_Dosyası.Sheets("Sayfa1")
.Cells(Satır, "A") = Cells(Y, "A")
.Cells(Satır, "E") = Cells(Y, "E")
.Cells(Satır, "I") = Cells(Y, "I")
.Cells(Satır, "J") = Cells(Y, "J")
End With
Satır = Satır + 1
Next
For S = 14 To Cells(65536, 12).End(3).Row
Satır1 = Veri_Dosyası.Sheets("Sayfa1").Range("l65536").End(3).Row + 1
With Veri_Dosyası.Sheets("Sayfa1")
.Cells(Satır1, "L") = Cells(S, "L")
.Cells(Satır1, "M") = Cells(S, "M")
.Cells(Satır1, "N") = Cells(S, "N")
End With
Satır1 = Satır1 + 1
Next
For T = 14 To Cells(65536, 16).End(3).Row
Satır2 = Veri_Dosyası.Sheets("Sayfa1").Range("p65536").End(3).Row + 1
With Veri_Dosyası.Sheets("Sayfa1")
.Cells(Satır2, "P") = Cells(T, "P")
.Cells(Satır2, "R") = Cells(T, "R")
.Cells(Satır2, "V") = Cells(T, "V")
End With
Satır2 = Satır2 + 1
Next

Kaynak_Dosya.Close True
Next
End If
Application.ScreenUpdating = True
Exit Sub
Son:
Application.ScreenUpdating = True
MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
End Sub

 

[Ömer]

Eğer verileri bu şekilde alacaksanız; y-s ve t döngülerini kurmanıza gerek yok. Kodları aşağıdakilerle değiştirin.

Sub TÜM_VERİLERİ_AL()
 
    Dim son As Long, Dosya_Yolu As String, Satır As Long
    Dim Veri_Dosyası As Workbook, Dosya As Object, Kaynak_Dosya As Workbook
        
    On Error GoTo son
    Application.ScreenUpdating = False
    
    [G7] = ThisWorkbook.Path
    Set Veri_Dosyası = ThisWorkbook
    Veri_Dosyası.Sheets("Sayfa1").Rows("11:" & Rows.Count).Delete
    
    Dosya_Yolu = Veri_Dosyası.Path & "\" & "VERİLER"
    
    If CreateObject("Scripting.FileSystemObject").FolderExists(Dosya_Yolu) Then
        If CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files.Count = 0 Then GoTo son
        For Each Dosya In CreateObject("Scripting.FileSystemObject").GetFolder(Dosya_Yolu).Files
            Set Kaynak_Dosya = Workbooks.Open(Dosya, False, False)
            son = Cells.Find("*", , , , xlByRows, xlPrevious).Row
            Satır = Veri_Dosyası.Sheets("Sayfa1").Cells(Rows.Count, "A").End(xlUp).Row + 1
            If son > 13 Then Rows("14:" & son).Copy Veri_Dosyası.Sheets("Sayfa1").Rows(Satır)
            Kaynak_Dosya.Close True
        Next Dosya
    End If
    
    Application.ScreenUpdating = True
    Exit Sub
son:
    Application.ScreenUpdating = True
    MsgBox "Dosya bulunamamıştır !", vbCritical, "Dikkat !"
    
End Sub

.