Kapalı Dosyalardan Alt Alta Sıralı Veri Alma Yardımı

[Believing]

Sayın Uzman Arkadaşlar,

Web üzerindeki bir programdan .Csv formatında indirdiğimiz dosyaların A1;Q1 aralığındaki verilerin AÇIK isimli dosyaya alt alta sıralı olarak almak istiyoruz. Alınacak olan bu verilerin ise L1;Q1 aralığının sayı formatında olma zorunluluğu vardır. Zira sisteme geri yükleme yapılırken hata alınmaktadır. Örnek dosyalar ekteki gibi olup, konu detaylı şekinde anlatılmıştır. Bu konuda yetersiz olduğum için siz uzman arkadaşların, benim için çok değerli olan yardımlarını rica ediyorum.

Saygılarımla.

 

[halit3]

kod:

Dim Sayfa_Adı
Dim sut
Sub csvdenverial()

Sayfa_Adı = ActiveSheet.Name
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
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

sut = Worksheets(Sayfa_Adı).Cells(Rows.Count, "B").End(3).Row + 1

Liste1 (Klasor.Items.Item.Path)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
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 Liste1(yol As String)
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")

uzanti = fs.GetExtensionName(ThisWorkbook.Name)

Dim wb As Workbook

For Each Dosya In fs.getfolder(yol).Files
If ThisWorkbook.Name <> Dosya.Name Then
If LCase(fs.GetExtensionName(Dosya)) = "csv" Then
Set wb = Workbooks.OpenXML(Dosya)

Set ver = wb.Sheets(ActiveSheet.Name)

For s = 1 To 17
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, s) = ver.Cells(1, s)
Next s
sut = sut + 1
Application.DisplayAlerts = False

wb.Close False

If msg1 = vbYes Then
fs.DeleteFile Dosya
End If

End If
End If
Next

On Error GoTo sonraki
For Each f In fs.getfolder(yol).subfolders
Liste1 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[Believing]

Sayın halit3,

Öncelikle konuya gösterdiğiniz ilgi için size çok teşekkür ederim. Kodları verileri toplatacağımız sayfa aldım ve çalıştırdım veriler geldi, ancak L sütunu sayı formatında(0,00) fotmatında gelmemektedir bu sağlanabilirmi? Ayrıca bu makroyu her seferinde en kısa yolu ile nasıl çalıştırabilirim. Yani bir butona mı atamalıyım gibi.

Saygılarımla,

 

[halit3]

Sayın halit3,

Öncelikle konuya gösterdiğiniz ilgi için size çok teşekkür ederim. Kodları verileri toplatacağımız sayfa aldım ve çalıştırdım veriler geldi, ancak L sütunu sayı formatında(0,00) fotmatında gelmemektedir bu sağlanabilirmi? Ayrıca bu makroyu her seferinde en kısa yolu ile nasıl çalıştırabilirim. Yani bir butona mı atamalıyım gibi.

Saygılarımla,

Siz hangi sütunu sayı formatında istiyorsanız ana dosyanızda ki ilgili sayfada sütunları sayıya bir defalığına çevirin

Bu kod en kısa olarak böyle çalışır işlemler bir kaç saniye sürüyor.

 

[halit3]

Kodu güncelliyorum bazı dosyalarınızda birden fazla satır gördüm eğer birden fazla satırda veri varsa bu kodu kullanın

Dim Sayfa_Adı
Dim sut
Sub csvdenverial()

Sayfa_Adı = ActiveSheet.Name
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
Application.ScreenUpdating = False
Application.DisplayAlerts = False

If Right(Kaynak, 1) <> "\" Then Kaynak = Kaynak & "\"

sut = Worksheets(Sayfa_Adı).Cells(Rows.Count, "B").End(3).Row + 1

Liste1 (Klasor.Items.Item.Path)
Application.ScreenUpdating = True
Application.DisplayAlerts = True
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 Liste1(yol As String)
Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")

uzanti = fs.GetExtensionName(ThisWorkbook.Name)

Dim wb As Workbook

For Each Dosya In fs.getfolder(yol).Files
If ThisWorkbook.Name <> Dosya.Name Then
If LCase(fs.GetExtensionName(Dosya)) = "csv" Then
Set wb = Workbooks.OpenXML(Dosya)

Set ver = wb.Sheets(ActiveSheet.Name)

For i = 1 To ver.Cells(Rows.Count, "B").End(3).Row
For s = 1 To ver.Cells(1, Columns.Count).End(xlToLeft).Column
ThisWorkbook.Sheets(Sayfa_Adı).Cells(sut, s) = ver.Cells([COLOR="Red"]i[/COLOR], s)
Next s
sut = sut + 1
Next i

Application.DisplayAlerts = False

wb.Close False

If msg1 = vbYes Then
fs.DeleteFile Dosya
End If

End If
End If
Next

On Error GoTo sonraki
For Each f In fs.getfolder(yol).subfolders
Liste1 (f.Path)
sonraki:
Next

Set fL = Nothing
End Sub

 

[Believing]

Sayın Halit3,
Yeni fark ettiğimiz bir sorun ortaya çıktı. Bazı CSV formatındaki kapalı çalışma kitaplarında birden fazla kayıt bulunmaktadır. Yukarıdaki vermiş olduğunuz kodlar her kapalı dosyadan bir satırlık veri almaktadır. Sizeden tekrar çok değerli yardımınız rica ediyorum.
Saygılarımla.

 

[halit3]

Sayın Halit3,
Yeni fark ettiğimiz bir sorun ortaya çıktı. Bazı CSV formatındaki kapalı çalışma kitaplarında birden fazla kayıt bulunmaktadır. Yukarıdaki vermiş olduğunuz kodlar her kapalı dosyadan bir satırlık veri almaktadır. Sizeden tekrar çok değerli yardımınız rica ediyorum.
Saygılarımla.

Nerdeyse 25 gün olmuş hiç geri dönüş yapmadınız.
5 Nolu mesajdaki kod söylediğiniz işlemi yapmıyormu

 

[Believing]

Maalesef 5. mesajdaki kodlar çalışma kitaplarından sadece bir satır veri almaktadır.

 

[halit3]

5 Nolu mesajdaki kodu AÇIK.xls dosyasında bir modüle koydum ve kodu çalıştırdım bir dosyanının içinde birden fazla veri var hepsini aldı.

Ekli rar dosyasındaki klasörü çıkart ve işlemi yap sonuçları irdele

 

[Believing]

Sayın Halit bey,

Konu amacına ulaşmıştır. Tarafıma verdiğiniz destek için size çok teşekkür ederim.
Bilgi paylaşıldıkca güzeldir sözünden yola çıkarak ALLAH sizden ve sevdiklerinizden razı olsun.

Saygılarımla.
Ömer ÜZÜMCÜ

 

[halit3]

teşekkürler iyi çalışmalar