Ado ile rakamların metin olarak gelmesi

[aureliane]

merhabalar, aşağıdaki kodu forumdan buldum, kapalı dosyadan veri alıyorum fakat rakamlar metin olarak geliyor, bunu nasıl düzeltebilirim. ikinci olarak kopyaladığı veriyi a1 e yapıştırıyor, bunu a sütünundaki ilk boş hücre olarak nasıl revize edebilirim.

Sub al()
    Dim con As Object, rs As Object
    Dim dosya As String
    dosya = ThisWorkbook.Path & "\veri.xlsm"
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordset")
    With Sayfa2
        con.Open "provider=microsoft.ACE.oledb.12.0;data source=" & dosya & _
        ";extended properties=""Excel 12.0;hdr=no"""
        rs.Open "select * from [Sayfa1$]", con, 1, 1
            If rs.RecordCount > 0 Then
                .Range("A1").CopyFromRecordset rs
            End If
        rs.Close: con.Close
    End With
    Sayfa2.Select
    Set rs = Nothing: Set con = Nothing
    dosya = vbNullString
End Sub

 

[hmtstc]

.range("A1") yerine

.range("A" & cells(rows.count,1).end(xlup).row+1) ile son satıra yazabilir.


Metin sayı olayını bilmiyorum maalesef

 

[aureliane]

.range("A1") yerine

.range("A" & cells(rows.count,1).end(xlup).row+1) ile son satıra yazabilir.


Metin sayı olayını bilmiyorum maalesef

olmadı hocam o şekilde.

yokmu acaba yardım edebilecek birileri.

 

[aureliane]

yokmu bu konuyu bilen birisi arkadaşlar,
kaynak dosyadaki tarih, sayı ne olursa olsun metin olarak alıyor.

 

[Haluk]

Örnek dosyanızı eklerseniz, birisi ilgilenebilir belki ...

.

 

[aureliane]

https://www.dosya.tc/server28/33tukp/ado.rar.html örnek dosyamı ekledim, ayrıca ilk ve son sütunun ilk hücrelerini de almıyor.

 

[Korhan Ayhan]

Bende bir sıkıntı olmadı. Sayılar sayı olarak geliyor. Tarihler için sütunu biçimlendirmeniz gerekir.

Alt alta veri aktarımı için .Range("A2").CopyFromRecordset rs satırını aşağıdaki gibi değiştiriniz.

.Cells(.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset rs

 

[aureliane]

çok teşekkürler ilgilendiğiniz için korhan hocam, aynen dediğiniz şekilde çalıştı, sürekli metin olarak saklanan sayı diye uyarı veriyordu ama o da düzeldi benim dikkatsizliğim kusura bakmayın.

 

[Korhan Ayhan]

Başlıklar ve biçimlendirme için aşağıdaki gibi kullanabilirsiniz.

Option Explicit

Sub Kapali_Dosyadan_Verileri_Al()
    Dim Baglanti As Object, Kayit_Seti As Object, Dosya As String, X As Integer
   
    Dosya = ThisWorkbook.Path & "\veri.xlsm"
   
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
   
    Baglanti.Open "Provider=Microsoft.ACE.OleDb.12.0;Data Source=" & Dosya & _
    ";Extended Properties=""Excel 12.0;Hdr=Yes"""
   
    Kayit_Seti.Open "Select * From [Sayfa1$]", Baglanti, 1, 1
   
    If Kayit_Seti.RecordCount > 0 Then
        With Sayfa1
            .Cells(.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
            .Range("A2:A" & .Cells(.Rows.Count, 1).End(3).Row).NumberFormat = "dd.mm.yyyy"
             For X = 0 To Kayit_Seti.Fields.Count - 1
                .Cells(1, X + 1) = Kayit_Seti.Fields(X).Name
             Next
            .Range("A1:E1").Font.Bold = True
            .Columns.AutoFit
        End With
    End If
   
    Kayit_Seti.Close
    Baglanti.Close
   
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
   
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[aureliane]

çok teşekkürler hocam, birde sizi bulmuşken merak ettiğim birşey var.
ThisWorkbook.Path & "\veri.xlsm" bu kısımda anladığım kadarıyla bu dosyanın olduğu yerde veri.xlsm var diyoruz, bunun yerine bu dosyanın olduğu yerin bir üst klasöründe veri.xlsm var deme şansımız oluyormu ?

 

[Haluk]

Şöyle olabilir....

Sub Test()
    Dim myPath As String
    myPath = ThisWorkbook.Path & "\.."
    MsgBox Dir(myPath & "\Veri.xlsx")
End Sub

Veya, başka bir örnek;

Sub Test2()
    Dim myFile As String
    myFile = ThisWorkbook.Path & "\..\Veri.xlsx"
    Workbooks.Open myFile
End Sub

.

 

[Korhan Ayhan]

@Haluk beyin çözümüne ek olarak;

Bir üst klasör için aşağıdaki gibi kullanabilirsiniz.

Üstteki mesajımda ki Dosya değişkenini değiştiriniz.

1. Yöntem;

Dosya = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1) & "\veri.xlsm"

2. Yöntem;

Set FSO = CreateObject("Scripting.FileSystemObject")
Dosya = FSO.GetParentFolderName(ThisWorkbook.Path) & "\veri.xlsm"

3. Yöntem; (Bu yöntemdeki tanımlamaları kod içinde en üst satıra alabilirsiniz.)

Dim Yol As Variant, Dosya As String
Yol = Split(ThisWorkbook.Path, "\")
ReDim Preserve Yol(0 To UBound(Yol) - 1)
Dosya = Join(Yol, "\") & "\veri.xlsm"

 

[aureliane]

Çok teşekkür ederim hocam ikinizede, çok hayır duamı aldınız. Hemen uyguluyorum kendi projeme göre.

 

[aureliane]

Hocam bir sorum daha olacak bu konuyla ilgili; veri.xlsm den sayfa1 i komple almak yerine oradan bir hücre aralığı alabiliyormuyuz, C7:H10000 gibi mesela

 

[Korhan Ayhan]

Elbette alabilirsiniz.

Deneyiniz.

Option Explicit

Sub Kapali_Dosyadan_Verileri_Al()
    Dim Baglanti As Object, Kayit_Seti As Object, Dosya As String, X As Integer
    
    Dosya = Left(ThisWorkbook.Path, InStrRev(ThisWorkbook.Path, "\") - 1) & "\veri.xlsm"
    
    Set Baglanti = CreateObject("AdoDb.Connection")
    Set Kayit_Seti = CreateObject("AdoDb.Recordset")
    
    Baglanti.Open "Provider=Microsoft.ACE.OleDb.12.0;Data Source=" & Dosya & _
    ";Extended Properties=""Excel 12.0;Hdr=Yes"""
    
    Kayit_Seti.Open "Select * From [Sayfa1$C7:H10000]", Baglanti, 1, 1
    
    If Kayit_Seti.RecordCount > 0 Then
        With Sayfa1
            .Cells(.Rows.Count, 1).End(3)(2, 1).CopyFromRecordset Kayit_Seti
            .Range("A2:A" & .Cells(.Rows.Count, 1).End(3).Row).NumberFormat = "dd.mm.yyyy"
             For X = 0 To Kayit_Seti.Fields.Count - 1
                .Cells(1, X + 1) = Kayit_Seti.Fields(X).Name
             Next
            .Range("A1:E1").Font.Bold = True
            .Columns.AutoFit
        End With
    End If
    
    Kayit_Seti.Close
    Baglanti.Close
    
    Set Kayit_Seti = Nothing
    Set Baglanti = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[aureliane]

Allah razı olsun hocam sizden

 

[aureliane]

korhan hocam size zahmet dosyama bir bakabilirmisiniz, daha önce sorduğum rakamların metin olarak gelmesi konusunda,
sizin yazdığınız kodlar başka yerde çok güzel çalışıyor ama benim dosyamda bir sorun var.
herapetrol.xlsm dosyamdaki istasyona makrosu sayı ve tarih olarak biçimli hücrelere metin olarak giriş yapıyor, nereyi yanlış yapıyorum bakarsanız çok sevinirim.

dosya.rar dosyasını indir - download

dosya.rar dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

www.dosya.tc

 

[Korhan Ayhan]

"data" dosyanızda "istasyona" sayfasında 4. satırdan itibaren boş gibi görünen hücreler var. Bu satırların tümünü SİLEREK dosyayı kaydettikten sonra tekrar deneyiniz.

ADO kullanmak istiyorsanız bazı kurallara uymak zorundasınız. Yoksa sürekli problem yaşarsınız.

 

[aureliane]

göremedim hocam o hücreleri, yinede sildim ama değişen bir şey olmadı şu an

 

[Korhan Ayhan]

"istasyona" sayfasında CTRL+END tuşlarına bastığınızda en son hücre hangisi görünüyor.