Kapalı CSV Dosyasından Veri Çekmek

Orion1 · 19 Kasım 2018

mrwarrior' Alıntı:
Aynen hocam. Örnek var ikinci mesajda. Xls dosyaları var. Onları alıp ana klasörde sayfa1 de a2 den başlayarak yaoıltıracak.

Dosyanız aşağıdaki linkte mevcuttur.

DOSYA İNDİR

Kod:

Sub csvaktar59V3()
Dim dosya, conn As Object, rs As Object, sat As Long
Dim ds, f, dsy As String, a As String
ChDir (ThisWorkbook.Path)
Sheets("Sayfa1").Select
Range("A2:A" & Rows.Count).ClearContents
dosya = Application.GetOpenFilename("excel dosyaları,*.xls", , "xls dosya seçiniz.")
If dosya = False Then
    MsgBox "xls dosya seçilmemiştir."
    Exit Sub
End If
Set ds = CreateObject("Scripting.FileSystemObject")
f = ds.GetFileName(dosya)
dsy = Left(f, Len(f) - 4)
sat = 1
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("adodb.recordset")
conn.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
                            dosya & ";extended properties=""excel 12.0;hdr=no"""
rs.Open "select * from[" & dsy & "$A:A];", conn, 1, 1
rs.movefirst
Do While Not rs.EOF
    Cells(sat, "A").Value = Replace(Split(rs(0).Value, ",")(2), """", "")
    sat = sat + 1
    rs.movenext
Loop
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "bitti"
End Sub

mrwarrior · 20 Kasım 2018

Allah razı olsun hocam. Tuttuğunuzu Makro etsin

Orion1 · 20 Kasım 2018

mrwarrior' Alıntı:
Allah razı olsun hocam. Tuttuğunuzu Makro etsin

Bilmukabele sizinde.

mrwarrior · 21 Kasım 2018

Hocam Tekrar rahatsız ediyorum. Ancak 1. incelemem doğruymuş. Araştırıken acaba XLS ye çeviripte veri alabilirmiyim diye incelerken dosyalar XLS kalmış

BU arada XLS halini arşivime ekledim. Teşekkür ederim.

Şİmdi sıkıntı CSV den veri almam gerekiyormuş. Ancak dosyada bir sürü veri olmasına karşın sadece 1. satırı alıyor. Diğer satıları almıyor. İkinci ise split komutunu kaldırınca hücreye sığdırmaya çalışarak tüm ekran düzenini bozuyor. Acaba yana yazı şeklinde yazabilir mi?

Şimdiden teşekkür ederim hocam.

Orion1 · 21 Kasım 2018

Siz ilk sorunuzda first name alınacak demiştiniz.Bende firstname sadece aldım.
Diğer başlıklarda alınacakmı?

Orion1 · 21 Kasım 2018

mrwarrior' Alıntı:
Hocam Tekrar rahatsız ediyorum. Ancak 1. incelemem doğruymuş. Araştırıken acaba XLS ye çeviripte veri alabilirmiyim diye incelerken dosyalar XLS kalmış BU arada XLS halini arşivime ekledim. Teşekkür ederim.

Şİmdi sıkıntı CSV den veri almam gerekiyormuş. Ancak dosyada bir sürü veri olmasına karşın sadece 1. satırı alıyor. Diğer satıları almıyor. İkinci ise split komutunu kaldırınca hücreye sığdırmaya çalışarak tüm ekran düzenini bozuyor. Acaba yana yazı şeklinde yazabilir mi?

Şimdiden teşekkür ederim hocam.

Bunun gibimi istediniz?

Dosyanız linktedir.

DOSYAYI INDIR

Kod:

Sub csvaktar59V4()
Dim dosya, sh As Worksheet, sat As Long
Dim ds, f, dsy As String, a As String, sut As Integer, i As Integer
ChDir (ThisWorkbook.Path)
Sheets("Sayfa1").Select
Range("A:CN").ClearContents
dosya = Application.GetOpenFilename("CSV dosyaları,*.csv", , "CSV dosya seçiniz.")
If dosya = False Then
    MsgBox "Csv dosya seçilmemiştir."
End If
Set ds = CreateObject("Scripting.FileSystemObject")
f = ds.GetFileName(dosya)
dsy = Left(f, Len(f) - 4)
sat = 1
Application.ScreenUpdating = False
Open (dosya) For Input As #1
Do While Not EOF(1)
    Line Input #1, a
    For i = 0 To UBound(Split(a, ","))
        sut = sut + 1
        Cells(sat, sut).Value = Replace(Split(a, ",")(i), """", "")
    Next
    sut = 0
    sat = sat + 1
Loop
Close #1
Application.ScreenUpdating = True

MsgBox "bitti"
End Sub

mrwarrior · 21 Kasım 2018

Gece bakacağım hocam. Zamanınızı ayırdığınız için Çoook teşekkür ederim.

mrwarrior · 23 Kasım 2018

Orion1' Alıntı:

Csv dosyalarınızla ana dosya ayni klasörde olmalıdır.
Dosya linki aşağıdadır.

DOSYA YUKLE

Kod:

Sub csvaktar59()
Dim dosya, sh As Worksheet, sat As Long
Dim ds, f, dsy As String, a As String
ChDir (ThisWorkbook.Path)
Sheets("Sayfa1").Select
Range("A2:A" & Rows.Count).ClearContents
dosya = Application.GetOpenFilename("CSV dosyaları,*.csv", , "CSV dosya seçiniz.")
If dosya = False Then
    MsgBox "Csv dosya seçilmemiştir."
End If
Set ds = CreateObject("Scripting.FileSystemObject")
f = ds.GetFileName(dosya)
dsy = Left(f, Len(f) - 4)
sat = 1
Open (dosya) For Input As #1
Do While Not EOF(1)
    Line Input #1, a
    Cells(sat, "A").Value = Replace(Split(a, ",")(2), """", "")
    sat = sat + 1
Loop
Close #1

MsgBox "bitti"
End Sub

Orion1' Alıntı:

Bunun gibimi istediniz?

Dosyanız linktedir.

DOSYAYI INDIR

Kod:

Sub csvaktar59V4()
Dim dosya, sh As Worksheet, sat As Long
Dim ds, f, dsy As String, a As String, sut As Integer, i As Integer
ChDir (ThisWorkbook.Path)
Sheets("Sayfa1").Select
Range("A:CN").ClearContents
dosya = Application.GetOpenFilename("CSV dosyaları,*.csv", , "CSV dosya seçiniz.")
If dosya = False Then
    MsgBox "Csv dosya seçilmemiştir."
End If
Set ds = CreateObject("Scripting.FileSystemObject")
f = ds.GetFileName(dosya)
dsy = Left(f, Len(f) - 4)
sat = 1
Application.ScreenUpdating = False
Open (dosya) For Input As #1
Do While Not EOF(1)
    Line Input #1, a
    For i = 0 To UBound(Split(a, ","))
        sut = sut + 1
        Cells(sat, sut).Value = Replace(Split(a, ",")(i), """", "")
    Next
    sut = 0
    sat = sat + 1
Loop
Close #1
Application.ScreenUpdating = True

MsgBox "bitti"
End Sub

Hocam programı denedim. veri alıyor ama ancak 1 veriyi alıyor. Sadece aldığı dosyadaki A1 hücresindeki veriyi aldı. Dİğerlerini almadı. Ancak bakma fırsatım oldu ilginiz için teşekkür ederim.

mrwarrior · 23 Kasım 2018

Hocam başlıklar alınmasına gerekte yok. Ben verileri istiyorum. A2 hücresinden itibaren aşağıya doğru bir sürü hücre var. Onları A2 hücresinden başlayarak doldurmak istiyorum. Sadece başlıkları almak istemiyorum.

Orion1 · 23 Kasım 2018

bende aşağıdaki resim gibi oluyor.

halit3 · 23 Kasım 2018

Ben var olan mesajlardaki dosyalara baktım csv uzantılı örnek dosyalar yok

mrwarrior · 23 Kasım 2018

Hocam iki dosya var. Birini alıyor. AMa diğerini almadı. İkiside aynı tarz dosya görünüyor. Farkı anlamadım. Ama benimki çalışmayan dosya formatında? acaba farkı ne ?

Örnek CSV lerimi ekliyorum. Biri çalışıyor. Bİri çalışmıyor dediğim de sadece 1. satırı alıyor. Dİğerleri boş oluyor.

halit3 · 23 Kasım 2018

Alternatif kod:
Bu kod csv dosyasındaki bütün verileri sayfa ya alıyor

Kod:

Sub verial2()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

yol = ThisWorkbook.Path

With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Text Files", "*.csv", 1
.FilterIndex = 3
.InitialFileName = yol
.Show
'.Execute
If .SelectedItems.Count = 0 Then GoTo atla2
dosya = .SelectedItems(1)
sat = 4

Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")


ThisWorkbook.Worksheets(ActiveSheet.Name).Range("A1:CN" & Rows.Count).ClearContents
sayfa = ActiveSheet.Name


If LCase(fs.GetExtensionName(dosya)) = "csv" Then
Workbooks.OpenXML (dosya)
        
        
ActiveWorkbook.Worksheets(ActiveSheet.Name).Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

        
If WorksheetFunction.CountA(ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells) > 0 Then
sat = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ActiveWorkbook.Worksheets(ActiveSheet.Name).Range(ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells(1, 1), ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells(sat, sut)).Copy
ThisWorkbook.Sheets(sayfa).Paste Destination:=ThisWorkbook.Sheets(sayfa).Range("a1")

End If

Application.DisplayAlerts = False
ActiveWindow.Close
End If

atla2:

MsgBox "işlem tamam ", vbOKOnly + vbInformation, "uyarı"
End With

End Sub

halit3 · 23 Kasım 2018

Merhaba Sayın mrwarrior
Profilinizde Altın Üyeliğinizi görmedim dosya eklemeyi veya indirmeyi nasıl yapıyorsunuz.

Haluk · 23 Kasım 2018

Ben ADO ile verileri alan bir dosya hazırladım, ekte verilmektedir.

Bu dosya ile; "çalışmıyor" denilen dosyadan veriler düzgün bir şekilde alınıyor, "çalışıyor" denilen dosyadan ise sadece 44. satırda tuhaf bir şekilde veri alınıyor.

Çünkü; "çalışıyor" denilen CSV aslında formatına uygun olarak hazırlanmamış. Bu durumu; Excel'in Veri sekmesini kullanarak (ayraç olarak "," işaretlendiğinde) CSV dosyalarını manuel olarak Excel'e aktarmaya çalıştığınızda görebilirsiniz. Dosyalardan biri sorunsuz olarak aktarılırken, diğerinde sütunlar ayrıştırılmıyor. Muhtemelen dosya CSV uzantılı olmasına rağmen, gerektiği gibi CSV olarak üretilmemiş, belki modifiye edilmiştir.

.

mrwarrior · 23 Kasım 2018

Bende bi

halit3' Alıntı:
Merhaba Sayın mrwarrior
Profilinizde Altın Üyeliğinizi görmedim dosya eklemeyi veya indirmeyi nasıl yapıyorsunuz.

Halit hocam bende bilmiyorum. Eskiden üyeliğim vip vardı. Ben site değişince üyelik kaldırıldı sandım. Bilmiyorum nasıl yapıyorum. Sadece tıklama yapıyorum. Ayrıca indirmeden yapabiliyorum. Özelden yazıyorum hocam.

halit3 · 23 Kasım 2018

mrwarrior' Alıntı:
Bende bi

Halit hocam bende bilmiyorum. Eskiden üyeliğim vip vardı. Ben site değişince üyelik kaldırıldı sandım. Bilmiyorum nasıl yapıyorum. Sadece tıklama yapıyorum. Ayrıca indirmeden yapabiliyorum. Özelden yazıyorum hocam.

Aşağıdaki linki irdeleyiniz.
https://www.excel.web.tr/threads/altin-ueyelik.57910/

mrwarrior · 25 Kasım 2018

Merhaba

Haluk' Alıntı:
Ben ADO ile verileri alan bir dosya hazırladım, ekte verilmektedir.

Bu dosya ile; "çalışmıyor" denilen dosyadan veriler düzgün bir şekilde alınıyor, "çalışıyor" denilen dosyadan ise sadece 44. satırda tuhaf bir şekilde veri alınıyor.

Çünkü; "çalışıyor" denilen CSV aslında formatına uygun olarak hazırlanmamış. Bu durumu; Excel'in Veri sekmesini kullanarak (ayraç olarak "," işaretlendiğinde) CSV dosyalarını manuel olarak Excel'e aktarmaya çalıştığınızda görebilirsiniz. Dosyalardan biri sorunsuz olarak aktarılırken, diğerinde sütunlar ayrıştırılmıyor. Muhtemelen dosya CSV uzantılı olmasına rağmen, gerektiği gibi CSV olarak üretilmemiş, belki modifiye edilmiştir.

.

Hocam dosyanız çalışıyor. Teşekkür ederim. İstediğim oldu gibi

Sİz satırlara bölmüşsünüz. Acaba aynı dosyadan aldığı gibi virgülle ayrılmış olarak activecell komutu ile istenen sütuna alt alta yazmam mümkün mü?

halit3' Alıntı:
Aşağıdaki linki irdeleyiniz.
https://www.excel.web.tr/threads/altin-ueyelik.57910/

HOcam hala dosya indirebiliyorum şimdi denedim. Yönetime de haber verdim. Sıkıntı olmaması için altın üyelik alıyorum. onayı verdim. İnşallah yarın altın üyeyim

Ama sistemde bir hata var gibi

mrwarrior · 25 Kasım 2018

halit3' Alıntı:

Alternatif kod:
Bu kod csv dosyasındaki bütün verileri sayfa ya alıyor

Kod:

Sub verial2()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

yol = ThisWorkbook.Path

With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Text Files", "*.csv", 1
.FilterIndex = 3
.InitialFileName = yol
.Show
'.Execute
If .SelectedItems.Count = 0 Then GoTo atla2
dosya = .SelectedItems(1)
sat = 4

Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")


ThisWorkbook.Worksheets(ActiveSheet.Name).Range("A1:CN" & Rows.Count).ClearContents
sayfa = ActiveSheet.Name


If LCase(fs.GetExtensionName(dosya)) = "csv" Then
Workbooks.OpenXML (dosya)
     
     
ActiveWorkbook.Worksheets(ActiveSheet.Name).Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

     
If WorksheetFunction.CountA(ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells) > 0 Then
sat = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ActiveWorkbook.Worksheets(ActiveSheet.Name).Range(ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells(1, 1), ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells(sat, sut)).Copy
ThisWorkbook.Sheets(sayfa).Paste Destination:=ThisWorkbook.Sheets(sayfa).Range("a1")

End If

Application.DisplayAlerts = False
ActiveWindow.Close
End If

atla2:

MsgBox "işlem tamam ", vbOKOnly + vbInformation, "uyarı"
End With

End Sub

Hocam sizin kodunuz da işe yaradı. Haluk hocama dediğim gibi acaba sütunlara bölmeden sadece active hücre sütununa virgül ile girmesi mümkün mü?

Sanırım yaptım hocam. Yine de siz düzeltip yaparsanız daha memnun olurum.

ActiveWorkbook.Worksheets(ActiveSheet.Name).Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

BU satır ve

sut = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column

bu satırı silerek.

Şimdi istediğimi yaptırdım. Yardımınız için teşekkür ederim. Yeni soru ile karşınıza geliyorum.

mrwarrior · 9 Aralık 2020

Haluk' Alıntı:
Ben ADO ile verileri alan bir dosya hazırladım, ekte verilmektedir.

Bu dosya ile; "çalışmıyor" denilen dosyadan veriler düzgün bir şekilde alınıyor, "çalışıyor" denilen dosyadan ise sadece 44. satırda tuhaf bir şekilde veri alınıyor.

Çünkü; "çalışıyor" denilen CSV aslında formatına uygun olarak hazırlanmamış. Bu durumu; Excel'in Veri sekmesini kullanarak (ayraç olarak "," işaretlendiğinde) CSV dosyalarını manuel olarak Excel'e aktarmaya çalıştığınızda görebilirsiniz. Dosyalardan biri sorunsuz olarak aktarılırken, diğerinde sütunlar ayrıştırılmıyor. Muhtemelen dosya CSV uzantılı olmasına rağmen, gerektiği gibi CSV olarak üretilmemiş, belki modifiye edilmiştir.

.

Hocam dosyanız ile aşağıdaki excelden dosya almaya çalışıyorum. ADO ile çok daha hızlı olduğunu anladım. Aslında halit hocamın kodları ile alabiliyorum ama ADO ile mümkün mü?

halit3' Alıntı:

Alternatif kod:
Bu kod csv dosyasındaki bütün verileri sayfa ya alıyor

Kod:

Sub verial2()

Application.ScreenUpdating = False
Application.DisplayAlerts = False

yol = ThisWorkbook.Path

With Application.FileDialog(msoFileDialogOpen)
.Filters.Clear
.Filters.Add "Text Files", "*.csv", 1
.FilterIndex = 3
.InitialFileName = yol
.Show
'.Execute
If .SelectedItems.Count = 0 Then GoTo atla2
dosya = .SelectedItems(1)
sat = 4

Dim fs As Object, f As Object
Set fs = CreateObject("Scripting.FileSystemObject")


ThisWorkbook.Worksheets(ActiveSheet.Name).Range("A1:CN" & Rows.Count).ClearContents
sayfa = ActiveSheet.Name


If LCase(fs.GetExtensionName(dosya)) = "csv" Then
Workbooks.OpenXML (dosya)
       
       
ActiveWorkbook.Worksheets(ActiveSheet.Name).Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

       
If WorksheetFunction.CountA(ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells) > 0 Then
sat = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
sut = ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
ActiveWorkbook.Worksheets(ActiveSheet.Name).Range(ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells(1, 1), ActiveWorkbook.Worksheets(ActiveSheet.Name).Cells(sat, sut)).Copy
ThisWorkbook.Sheets(sayfa).Paste Destination:=ThisWorkbook.Sheets(sayfa).Range("a1")

End If

Application.DisplayAlerts = False
ActiveWindow.Close
End If

atla2:

MsgBox "işlem tamam ", vbOKOnly + vbInformation, "uyarı"
End With

End Sub

Kapalı CSV Dosyasından Veri Çekmek

Orion1

Uzman

mrwarrior

Orion1

Uzman

mrwarrior

Orion1

Uzman

Orion1

Uzman

mrwarrior

mrwarrior

mrwarrior

Orion1

Uzman

halit3

Uzman

mrwarrior

Ekli dosyalar

halit3

Uzman

halit3

Uzman

Haluk

Özel Üye

Ekli dosyalar

mrwarrior

halit3

Uzman

mrwarrior

mrwarrior

mrwarrior

Ekli dosyalar