Csv formatlı dosyaları birleştirmek

[ynsmrt]

macroyu yayınlayabilirmisinz linki indiremiyorum

 

[cavanoos]

Dim Kaynak As String
Dim sut As String
Dim Sayfa_Adı As String

Sub Start()
'D sürücüsünde ve belgelerim klasörüne birleştirilecek dosyaları bir klasör içinde topla ve makroyu başlat
a = MsgBox("Sayfayı Temizlemek istiyormusunuz.?", vbYesNo + vbInformation, " UYARI")
If a = vbYes Then
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Value = ""
Range(Cells(2, 1), Cells(Rows.Count, Columns.Count)).Interior.ColorIndex = xlNone
End If
Sayfa_Adı = ActiveSheet.Name
sut = 2
Set Klasor = CreateObject("shell.application").BrowseForFolder(0, "Lütfen bir klasör seçiniz", 50, &H0)
If Not Klasor Is Nothing Then
Kaynak = Klasor.SELF.Path
If InStr(1, Kaynak, "{") > 0 Then GoTo Atla
Call Liste(Kaynak, "")
Call AltListe(Kaynak, "")
Range("A1").Select
MsgBox "işlem tamam"
Else
Atla:
MsgBox "Lütfen Kaynak Klasör Seçimini Yapınız !", vbInformation, "DİKKAT"
End If
Set Klasor = Nothing
End Sub


Private Sub Liste(Klasor As String, uzanti As String)
Dim Hedef As Object, Kaynak As Object, Dosya As String
Set Hedef = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).SubFolders
Dim wb As Workbook
Dim DosyaSistemi
Set DosyaSistemi = CreateObject("Scripting.FileSystemObject")
Dosya = Dir(Klasor & "\*.csv" & uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents
Application.DisplayAlerts = False
If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
eski = Klasor & "\" & Dosya
yeni = Klasor & "\" & Mid(Dosya, 1, Len(Dosya) - 4) & ".xls"
FileCopy eski, yeni
DosyaSistemi.DeleteFile eski
End If
Dosya = Dir
Wend
On Error GoTo sonraki
For Each Kaynak In Hedef
Call Liste(Kaynak.Path, "")
sonraki:
Next
Set Hedef = Nothing
End Sub


Private Sub AltListe(Klasor As String, uzanti As String)
Dim Hedef As Object, Kaynak As Object, Dosya As String
Set Hedef = CreateObject("Scripting.FileSystemObject").GetFolder(Klasor).SubFolders
Dim wb As Workbook

Dosya = Dir(Klasor & "\*.**") ' & Uzanti)
Application.ScreenUpdating = False
While Dosya <> ""
DoEvents

If ThisWorkbook.Name <> Dosya Then
On Error Resume Next
Application.DisplayAlerts = False

Set wb = Workbooks.Open(Klasor & "\" & Dosya)
yeni_dosya_adı = ActiveWorkbook.Name
sayfaadi = ActiveSheet.Name

Set ver = Workbooks(Dosya).Sheets(ActiveSheet.Name)

If Cells(1, 1).Value = "" Then
Rows("1:1").Delete Shift:=xlUp
End If

ver.Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=";", FieldInfo:=Array(Array(1, 1), Array(1, 2), Array(1, 3))

satır = ver.Cells(Rows.Count, "B").End(3).Row

If sut + satır >= Rows.Count Then
Sheets.Add
Sheets(ActiveSheet.Name).Move After:=Sheets(ActiveWorkbook.Sheets.Count)
Sayfa_Adı = ActiveSheet.Name
sut = 2
End If

deg = "'" & Klasor & "\" & "[" & Dosya & "]" & sayfaadi & "'!R"
ThisWorkbook.Sheets(Sayfa_Adı).Range("A" & sut & "" & sut).Interior.ColorIndex = 6
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, 1).Interior.ColorIndex = 4
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, 1).Value = Klasor
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, 2).Interior.ColorIndex = 8
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, 2).Value = yeni_dosya_adı
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, 3).Interior.ColorIndex = 45
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, 3).Value = sayfaadi
sut = sut + 1

n = 1
For s = 1 To satır
For j = 1 To 4
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, n) = ExecuteExcel4Macro(deg & s & "C" & j)
If ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, n) = 0 Then
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, n) = ""
End If
n = n + 1
Next j
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut + 1, 1).Select
sut = sut + 1
n = 1
Next s

End If
Dosya = Dir
wb.Close False
Wend
On Error GoTo sonraki
For Each Kaynak In Hedef
Call AltListe(Kaynak.Path, "")
sonraki:
Next
Set Hedef = Nothing
End Sub

 

[burcin_end_muh]

Birde bu dosyayı dene son satırdaki veri kalacakmı

Halit Bey merhaba,

For s = 1 To satır
For j = 1 To 4

burdaki kodu 4ü 7 olarak değiştirdiğimde 7 sütundan oluşan csv dosyalarının başlıklarını alıyor 5inci sutun dahil olmak uzere verileri getiriyor 6 ve 7 sutunların alt değerlerini getirmiyor.


Yardımcı olabılır mısınız?