• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excel dosyasının bulunduğu klasörden veri alma

  • Konbuyu başlatan Konbuyu başlatan ahm3tt
  • Başlangıç tarihi Başlangıç tarihi
A

ahm3tt

Katılım
21 Kasım 2016
Mesajlar
18
Excel Vers. ve Dili
2016
Kod sanırım thisworkbook.path, ama nasıl kullanacağımı çözemedim.

dPModn.png
 

Ekli dosyalar

yapmak istediğimi net yazayım karışıklık olmasın.
excel dosyam ile aynı klasörde csv dosyaları olacak. bu klasörü farklı bilgisayarlarda flashımla açtığımda verileri alırken dosya yolu htası almak istemiyorum.
 
Böyle bir dene

Kod: 
[COLOR="Red"]Klasor = ThisWorkbook.Path & "\"[/COLOR]

    Sheets("TR").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" [COLOR="red"]& Klasor &[/COLOR] "table.csv", Destination:=Range( _
        "$A$1"))
        .Name = "table"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
 
halit3' Alıntı:
Böyle bir dene

Kod: 
[COLOR="Red"]Klasor = ThisWorkbook.Path & "\"[/COLOR]

    Sheets("TR").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" [COLOR="red"]& Klasor &[/COLOR] "table.csv", Destination:=Range( _
        "$A$1"))
        .Name = "table"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
Genişletmek için tıkla ...

hocam teşekkürler ilk veri dosyası için işe yaradı fakat "table (1).csv" dosyası için aynı kodu kullandığımda hata veriyor. Sanırım dosya adı içerisinde parantez işareti geçtiği için hata veriyor. çünkü

Kod: 
Sheets("MAT").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & Klasor & "table (1).csv", Destination:=Range( _
        Range("$A$1"))
kodu bu şekilde yaptığımda "("$A$1"))" bu ifadenin sonuna bi parantez daha kapamamı söylüyor(seperater hatası). "("$A$1")))" bu şekilde yaptığımda yine hata verdi.
 
ahm3tt' Alıntı:
hocam teşekkürler ilk veri dosyası için işe yaradı fakat "table (1).csv" dosyası için aynı kodu kullandığımda hata veriyor. Sanırım dosya adı içerisinde parantez işareti geçtiği için hata veriyor. çünkü

Kod: 
Sheets("MAT").Select
    Range("A1").Select
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;" & Klasor & "table (1).csv", Destination:=Range( _
        Range("$A$1"))
kodu bu şekilde yaptığımda "("$A$1"))" bu ifadenin sonuna bi parantez daha kapamamı söylüyor(seperater hatası). "("$A$1")))" bu şekilde yaptığımda yine hata verdi.
Genişletmek için tıkla ...

veri alınacak sayfalarla ilgili sayfa isimleri arasında boşluklar olması

Kod: 
"table (1).csv"
aşağıdaki gibi
Kod: 
"table(1).csv"

hem sayfa isimlerini düzelt hemde kodları bu şekilde düzelt
 
halit3' Alıntı:
veri alınacak sayfalarla ilgili sayfa isimleri arasında boşluklar olması

Kod: 
"table (1).csv"
aşağıdaki gibi
Kod: 
"table(1).csv"

hem sayfa isimlerini düzelt hemde kodları bu şekilde düzelt
Genişletmek için tıkla ...

hocam table.csv dosyalarını optik okuyucu sitesinden alıyorum, ismi otomatik table.csv olarak veriliyor. 6 ayrı ders olduğu için sırayla (1) (2) diye gidiyor. Boşluklar için kodda düzenleme yapamaz mıyız? yoksa her defasında dosya ismini manuel düzenlemem gerekecek.
 
veri aldığın dosyadan bir iki tanesini ekle buraya
 
Alternatif olarak bu kodu denermisiniz .

Kod: 
Sub verial5()

ReDim sayfalar(6)
ReDim dosyalar(6)

sayfalar(1) = ("TR")
sayfalar(2) = ("MAT")
sayfalar(3) = ("DİN")
sayfalar(4) = ("FEN")
sayfalar(5) = ("SOS")
sayfalar(6) = ("İNG")

dosyalar(1) = "table"
dosyalar(2) = "table (1)"
dosyalar(3) = "table (2)"
dosyalar(4) = "table (3)"
dosyalar(5) = "table (4)"
dosyalar(6) = "table (5)"

Klasor = ThisWorkbook.Path & "\"
  
For j = 1 To 6
Dosya = Klasor & dosyalar(j) & ".csv"
sat = 1
Open Dosya For Input As #1
 
Do While Not EOF(1)
Line Input #1, deg1

deg1 = Split(Trim(deg1), ",""")
If UBound(deg1) > 0 Then
For i = LBound(deg1) To UBound(deg1)
Sheets(sayfalar(j)).Cells(sat, i + 1) = Replace(deg1(i), """", "")
Next
sat = sat + 1
End If
Loop
Close #1

Next j

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


End Sub

not: veri dosyası ve veri alınacak dosyalar aynı klasörde olmalı
 
Bu kod da farklı

Kod: 
Sub verial2()
Klasor = ThisWorkbook.Path & "\"
son = 6

ReDim sayfalar(son)
ReDim dosyalar(son)

sayfalar(1) = ("TR")
sayfalar(2) = ("MAT")
sayfalar(3) = ("DİN")
sayfalar(4) = ("FEN")
sayfalar(5) = ("SOS")
sayfalar(6) = ("İNG")

dosyalar(1) = "table"
dosyalar(2) = "table (1)"
dosyalar(3) = "table (2)"
dosyalar(4) = "table (3)"
dosyalar(5) = "table (4)"
dosyalar(6) = "table (5)"


For k = 1 To son

If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & dosyalar(k) & ".csv") = True Then

    Sheets(sayfalar(k)).Range("A1:I500").ClearContents

    With Sheets(sayfalar(k)).QueryTables.Add(Connection:= _
        "TEXT;" & Klasor & dosyalar(k) & ".csv", Destination:=Sheets(sayfalar(k)).Range( _
        "$A$1"))
        .Name = dosyalar(k)
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    End If
    Next k
    
Dim qt As QueryTable
For Each qt In ActiveSheet.QueryTables
qt.Delete
Next qt

MsgBox "işlem tamam"
End Sub
 
halit3' Alıntı:
Bu kod da farklı

Kod: 
Sub verial2()
Klasor = ThisWorkbook.Path & "\"
son = 6

ReDim sayfalar(son)
ReDim dosyalar(son)

sayfalar(1) = ("TR")
sayfalar(2) = ("MAT")
sayfalar(3) = ("DİN")
sayfalar(4) = ("FEN")
sayfalar(5) = ("SOS")
sayfalar(6) = ("İNG")

dosyalar(1) = "table"
dosyalar(2) = "table (1)"
dosyalar(3) = "table (2)"
dosyalar(4) = "table (3)"
dosyalar(5) = "table (4)"
dosyalar(6) = "table (5)"


For k = 1 To son

If CreateObject("Scripting.FileSystemObject").FileExists(Klasor & dosyalar(k) & ".csv") = True Then

    Sheets(sayfalar(k)).Range("A1:I500").ClearContents

    With Sheets(sayfalar(k)).QueryTables.Add(Connection:= _
        "TEXT;" & Klasor & dosyalar(k) & ".csv", Destination:=Sheets(sayfalar(k)).Range( _
        "$A$1"))
        .Name = dosyalar(k)
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 65001
        .TextFileStartRow = 1
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = True
        .TextFileSemicolonDelimiter = False
        .TextFileCommaDelimiter = True
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    End If
    Next k
    
Dim qt As QueryTable
For Each qt In ActiveSheet.QueryTables
qt.Delete
Next qt

MsgBox "işlem tamam"
End Sub
Genişletmek için tıkla ...

Çok teşekkür ederim hocam, sizi de uğraştırdım bayağı. Önceki kod işe yaradı ama türkçe karakter problemi oldu ama bu son gönderdiğiniz kusursuz çalışıyor. Tekrar teşekkürler.:ok::
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst