*.xls ve *.csv dosyalarından veri alma.

[ottoman71]

Merhaba arkadaşlar.

Excel çalışma sayfama farklı yerdeki *.xls ve *.csv dosyarından veri almak istiyorum. Veri al butonuna tıkladığımda her açtığım dosyayı bir boşluk bırakarak alt alta ekleyecek. Dosya eklemye A2 hücresinden başlayacak ve her açılan dosya arasında bir satır boşluk olacak. Çalışma sayfam boş ise A2'den başlayacak. Dolu ise dolu satırdan aşağı bir boşluk bırakıp ekleyecek. Yani daha önceki verileri silmeyecek.

Yardımcı olurmusunuz.

Kolay gelsin.

 

[Orion1]

Merhaba arkadaşlar.

Excel çalışma sayfama farklı yerdeki *.xls ve *.csv dosyarından veri almak istiyorum. Veri al butonuna tıkladığımda her açtığım dosyayı bir boşluk bırakarak alt alta ekleyecek. Dosya eklemye A2 hücresinden başlayacak ve her açılan dosya arasında bir satır boşluk olacak. Çalışma sayfam boş ise A2'den başlayacak. Dolu ise dolu satırdan aşağı bir boşluk bırakıp ekleyecek. Yani daha önceki verileri silmeyecek.

Yardımcı olurmusunuz.

Kolay gelsin.

Örnek dosyalarınızı ekleyiniz.
Şimdi afaki bir şey diyemiyecem.Olur elbet.

 

[ottoman71]

Örnek dosyalarınızı ekleyiniz.
Şimdi afaki bir şey diyemiyecem.Olur elbet.

Dosya eklenmiştir.

 

[halit3]

buna benzer bir konu
aşağıdeki linkte işlenmiştir
http://www.excel.web.tr/showthread.php?t=87309

 

[halit3]

bu dosya işinizi görürmü

tek yapacagınız iş verilerin bulunduğu klasörü seçmek

 

[Orion1]

Asıl dosya diğer dosyalarla ayni klasörde olması lazım.
Dosyanız ektedir.

Sub Verial_59()
Dim sat As Long, myarr(), z As Object, s
Dim fso As Object, fs As Object, dosya As Object, sh As Worksheet
Dim kayit, n As Long, k As Byte, t As Long, a()
Dim say As Integer, s1 As Worksheet
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.getfolder(ThisWorkbook.Path).Files
For Each s1 In Worksheets
    If Left(s1.Name, 4) = "Veri" Then
        If CInt(Replace(s1.Name, "Veri", "")) > say Then
            Set sh = s1
            say = CInt(Replace(s1.Name, "Veri", ""))
        End If
    End If
Next
ReDim myarr(1 To 10, 1 To 65536)
Application.ScreenUpdating = False
For Each dosya In f
    If dosya.Name <> ThisWorkbook.Name Then
        If UCase(Right(dosya.Name, 4)) = UCase(".CSV") Then
            Set z = fso.opentextfile(dosya, 1)
            s = Split(CStr(z.ReadAll()), vbCrLf, , vbTextCompare)
            For t = LBound(s) To UBound(s) - 1
                n = n + 1
                kayit = Split(s(t), ";", , vbTextCompare)
                For k = 0 To UBound(kayit)
                    myarr(k + 1, n) = kayit(k)
                Next k
            Next t
            z.Close
        ElseIf UCase(Right(dosya.Name, 4)) = UCase(".XLS") Then
            If Workbooks.Open(dosya).ReadOnly = True Then Workbooks(dosya.Name).Close False
            sat3 = Workbooks(dosya.Name).Sheets(1).Cells(65536, "A").End(xlUp).Row
            a = Workbooks(dosya.Name).Sheets(1).Range("A1:A" & sat3).Value
            Workbooks(dosya.Name).Close False
            For i = 1 To UBound(a)
                n = n + 1
                kayit = Split(a(i, 1), ";", , vbTextCompare)
                For k = 0 To UBound(kayit)
                    myarr(k + 1, n) = kayit(k)
                Next k
            Next i
        End If
        n = n + 1
        For k = 1 To 10
                myarr(k, n) = ""
        Next k
    End If
Next
ThisWorkbook.Activate
sat = sh.Cells(65536, "A").End(xlUp).Row + 1
If n > 65533 Then
    MsgBox "Toplamda alınan veriler bir sayfaya sığmayacak kadar büyük." & _
    vbLf & "Klasörden bir kaç dosya çıkarıp tekrar deneyiniz.", vbCritical, "UYARI"
    GoTo son
End If
If sat + n >= 65533 Then
    say = say + 1
    ThisWorkbook.Activate
    Worksheets.Add after:=Worksheets(sh.Name)
    ActiveSheet.Name = "Veri" & say
    Set sh = Worksheets(ActiveSheet.Name)
    sat = 2
End If
ReDim Preserve myarr(1 To 10, 1 To n)
sh.Range("A" & sat).Resize(n, 10) = Application.Transpose(myarr)
son:
Application.ScreenUpdating = True
Erase a: Erase myarr
Set sh = Nothing: Set fso = Nothing: Set dosya = Nothing
Set z = Nothing
MsgBox "İşlem tamamlanmıştır" & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub

 

[halit3]

5 nolu mesajdaki dosyaya eklemeler yaptım sayfa bitince yeni sayfa oluşturması için

 

[Orion1]

Sayfa doluyorsa yeni bir sayfa açıyor.Verileri Veri isminde sayfaya kaydediyor.
Dosyayı 5 numaralı mesajdan indirebilirsiniz.

 

[ottoman71]

Evren Hocam ve Halit Hocam ikinizede teşekkur ederim.

Ellerinize sağlık.

 

[halit3]

Evren Hocam ve Halit Hocam ikinizede teşekkur ederim.

Ellerinize sağlık.

iyi çalışmalar

 

[Orion1]

Rica ederim.
İyi çalışmalar.

 

[ottoman71]

bu dosya işinizi görürmü

tek yapacagınız iş verilerin bulunduğu klasörü seçmek

Halit Hocam,
Bu konuda tekrar yardımınıza ihtiyacım var. Yardımcı olabilirseniz sevinirim.

Seçtiğimiz klasörlerdeki excel dosyalarının excel sayfama çağırdım.Sayfama, excel dosyalarının içerisindeki bilgileri atarken de, her satıra hangi dosyadan olduğunu en son dolu sütundan sonraki boş sütuna yazacak.


İyi çalışmalar.

 

[halit3]

Halit Hocam,
Bu konuda tekrar yardımınıza ihtiyacım var. Yardımcı olabilirseniz sevinirim.

Seçtiğimiz klasörlerdeki excel dosyalarının excel sayfama çağırdım.Sayfama, excel dosyalarının içerisindeki bilgileri atarken de, her satıra hangi dosyadan olduğunu en son dolu sütundan sonraki boş sütuna yazacak.


İyi çalışmalar.

ekli dosyaya bir bakınız.

 

[ottoman71]

Halit Hocam deneme2.rar dosyası dosya ismini yazıyor. Fakat dosyaları açtığı yere, ilk dosya adresini, sonra dosya ismini ve ardından listeyi ekliyor. Benim yapmak istediğim;
Listenin, en son dolu sütunundan sonraki boş sütuna dosya isimlerini yazmak. Açtığımız dosya 50 satırsa, 50 satıra dosya ismini yazacak.

Halit hocam örnek dosyayı ekledim. İnceleyebilir misiniz?
Kolay gelsin

 

[halit3]

Halit Hocam deneme2.rar dosyası dosya ismini yazıyor. Fakat dosyaları açtığı yere, ilk dosya adresini, sonra dosya ismini ve ardından listeyi ekliyor. Benim yapmak istediğim;
Listenin, en son dolu sütunundan sonraki boş sütuna dosya isimlerini yazmak. Açtığımız dosya 50 satırsa, 50 satıra dosya ismini yazacak.

Halit hocam örnek dosyayı ekledim. İnceleyebilir misiniz?
Kolay gelsin

ekli dosyaya bir bakarmısınız.?

 

[ottoman71]

ekli dosyaya bir bakarmısınız.?

Halit Hocam ellerinize sağlık tam istediğim gibi olmuş.Teşekkür ederim
Yalnız gri ile boya yerlere dosya konumu yazmakta. O satırın sadece boş olmasını sa sağlayabilir miyiz? Sizi çok uğraştırdım kusura bakmayın
İyi çalışmalar.

 

[halit3]

Halit Hocam ellerinize sağlık tam istediğim gibi olmuş.Teşekkür ederim
Yalnız gri ile boya yerlere dosya konumu yazmakta. O satırın sadece boş olmasını sa sağlayabilir miyiz? Sizi çok uğraştırdım kusura bakmayın
İyi çalışmalar.

Kodun içindeki aşağıdaki bölümü sililiniz.

ThisWorkbook.Sheets(Sayfa_Adı).Range("A" & sut).Value = Klasor & "\" & Dosya

 

[ottoman71]

Kodun içindeki aşağıdaki bölümü sililiniz.

ThisWorkbook.Sheets(Sayfa_Adı).Range("A" & sut).Value = Klasor & "\" & Dosya

Teşekkür ederim.
İyi çalışmalar.

 

[halit3]

Teşekkür ederim.
İyi çalışmalar.

iyi çalışmalar

 

[cybermaniac]

merhaba

arkadaslar aynı atrzda ben de ortalama 150 csv den data cekmem gerekiyor ancak benim datalarim daha farkli az önceki makroyu indirp biraz baktim sadece csv leri xls cevirip birakiyor.Benim csv kayıtlarim icinde donanım envanteri loglari var.Yani hardware listler.3rd party bir tool ile csv ye aktararak aldigim hardware listesi.ben bunu excele yazmaktansa bir kod ile hepsini tek kalemde bitirmek istiyorum.Acikcasi.dilerseniz csv dosyasini ekte sunuyorum bana bu konuda yardimci olursaniz sevinirim.

Excel formatim ne sekilde olucak derseniz eger örnek vereyeim ;

Makine adi : kullanıcı adi : Anakart modeli : bios versiyonu : Ram : Cpu : Hdd : ( bu satirlarin altina alt alta bilgiler gelecek sekilde csv deki datalari bunlarin altina istiyorum)

umarim anlatabilmişimdir....csv fle i ektededir...ilginiz icin tesekkur ederim.bu arada pek fazla makrolardan anlamam biraz detayli yardimci olabilirseniz sevinirim.