Belli karaktere kadar dosya açma

[tahsinanarat]

Con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & _
"C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip_2022_28012022_2038.xlsb" & ";extended properties=""excel 12.0;hdr=no;imex=no"""

Yukarıdaki Ado kodu ile kapalı dosyadan 01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip_2022_28012022_2038.xlsb adlı dosyadan veri çekebiliyorum, ancak dosya ismindeki 1200 Malzeme_Stok_Takip den sonrasi devamlı değişken tarih olduğundan ben saadece 1200 Malzeme_Stok_Takip ismini gördüğünde yani ilk 23 karaktere kadar aynı ise veri getirmesini istiyorum.
Teşekkürler.

 

[Korhan Ayhan]

Dosya adının olduğu bölümü aşağıdaki gibi değiştirip deneyiniz.

Dir("C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip*")

İlgili klasörde benzer isimli dosya varsa kodun sorunsuz çalışması gerekir.

 

[tahsinanarat]

Sub Veri_Aktar1()
Sheets("Envanter").Select
Range("A6:G65000").ClearContents
Set Con = CreateObject("Adodb.Connection"): Set rs = CreateObject("Adodb.RecordSet")


Con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & _
Dir("C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip*") & ";extended properties=""excel 12.0;hdr=no;imex=no"""
If Sayfa1.Range("d3") <> 0 Then
sorgu = "Select f1,f2*1,F3,F4,F5*1,F6*1,F7*1 from [Proje_Envanter$A5:G65536] WHERE f4='" & Sayfa1.Range("D3") & "' And f7 < 0"
Else
sorgu = "Select f1,f2*1,F3,F4,F5*1,F6*1,F7*1 from [Proje_Envanter$A5:G65536] WHERE f7 < 0"

End If
rs.Open sorgu, Con, 1, 1
Range("a6").CopyFromRecordset rs
rs.Close: Con.Close
Set Con = Nothing: Set rs = Nothing: sorgu = Empty
ActiveSheet.Columns("A:AA").EntireColumn.AutoFit
On Error Resume Next
Range("A5:G5") = Array("MALZEME KODU", "SAP KODU", "MALZEME ADI", "PROJE", "GİREN", "ÇIKAN", "FARK")
Range("A5:G5").Font.Bold = True
End Sub

Resimdeki hatayı verdi hocam, dosya uzantısını da yazmayı denedim ancak yine hata verdi.

 

[Korhan Ayhan]

Hatada sayfa adından bahsediyor. Bunu kontrol etmelisiniz.

Eğer dosya adı sorunu olsaydı başka bir hata verirdi.

 

[tahsinanarat]

Sn. @Korhan Ayhan hocam, 1.mesajımdaki kod ile sonuç alıyorum, çalışıyor.

 

[Korhan Ayhan]

O zaman birde aşağıdaki gibi deneyiniz.

Dir("C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip*.*")

 

[tahsinanarat]

Sn. @Korhan Ayhan Hocam aynı hatayı verdi.

 

[Korhan Ayhan]

Ek olarak ilk önerdiğim kodu boş bir dosyada deneme yaptım. O kod da bende dosya adını üretiyor.

Aşağıdaki kodu deneyin dosya adını döndürüyorsa sizin başka sorununuz vardır.

Msgbox Dir("C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip*")

 

[tahsinanarat]

Döndürmedi hocam

Con.Open "Provider=Microsoft.Ace.Oledb.12.0;Data Source=" & _
Msgbox Dir("C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip*") & ";extended properties=""excel 12.0;hdr=no;imex=no"""

satırı tamamen kırmızı oldu.

 

[Korhan Ayhan]

Son verdiğim satırı tek başına deneyiniz.

 

[tahsinanarat]

Sn. @Korhan Ayhan Hoam;

C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip_

Tekrar gündeme geldi, bu şekilde dosyayı çağırmam gerekiyor,

diyelim ki dosyanın orjinali bu,
C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip_2022_28012022_2038.xlsb

değişken kısmı _2022_28012022_2038

Değişmeyen dosya adı 1200 Malzeme_Stok_Takip_
olacak.

Bundan önceki dediklerinizin hepsini denedim ancak sonuç alamadım.

 

[Korhan Ayhan]

Aşağıdaki kod sizde ne üretiyor?

Sub Test()
    MsgBox Dir("C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip*")
    MsgBox Dir("C:\Users\tomson\Desktop\01_OCAK_2022_Stok\1200 Malzeme_Stok_Takip?")
End Sub

 

[tahsinanarat]

Sub Test()
MsgBox Dir("C:\Users\tahsin.anarat\Desktop\01_OCAK_2023_Stok\1000 Malzeme_Stok_Takip*")
MsgBox Dir("C:\Users\tahsin.anarat\Desktop\01_OCAK_2023_Stok\1000 Malzeme_Stok_Takip?")
End Sub

 

[tahsinanarat]

Kod içerisinde kullandığımda verdiği hata;

Sub Girdi_guncelle()
Sheets("Girdi").Select
If Date >= CDate("31/5/2023") Then Exit Sub

Range("A2:az65000").ClearContents
Set con = CreateObject("Adodb.Connection"): Set rs = CreateObject("Adodb.RecordSet")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
Dir("C:\Users\tahsin.anarat\Desktop\01_OCAK_2023_Stok\1000 Malzeme_Stok_Takip*") & ";extended properties=""excel 12.0;hdr=no;imex=1"""


Sorgu = "Select F1,F2,F3,F13,F7,F8,F9,F10,F11  from [Girdi$A2:AA1000000]"

rs.Open Sorgu, con, 1, 1
Range("a2").CopyFromRecordset rs

rs.Close: con.Close
Set con = Nothing: Set rs = Nothing: Sorgu = Empty
ActiveSheet.Columns("A:AA").EntireColumn.AutoFit
On Error Resume Next
Range("b1").Select
End Sub

 

[Korhan Ayhan]

Hata veren kısmı aşağıdaki gibi düzenleyip deneyiniz.

"C:\Users\tahsin.anarat\Desktop\01_OCAK_2023_Stok\" & Dir("C:\Users\tahsin.anarat\Desktop\01_OCAK_2023_Stok\1000 Malzeme_Stok_Takip*")

 

[tahsinanarat]

Hocam, Deneyip bilgilendirecegim

 

[beab05]

Merhaba;

Alternatif olarak aşağıdaki gibi bağlantınızı test edip sorun olmaması halinde düzenleyebilirsiniz.

Sub ConnectToExcelWithADO()
    Dim conn As Object
    Dim rs As Object
    Dim sConnString As String
    Dim sFileName As String
    Dim sFolder As String
  
  
    sFolder = "C:\Users\tahsin.anarat\Desktop\01_OCAK_2023_Stok"
  
  
    sFileName = Dir(sFolder & "\1000 Malzeme_Stok_Takip*.xls*")

    Do While sFileName <> ""
      
      
        sConnString = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                      "Data Source=" & sFolder & "\" & sFileName & ";" & _
                      "Extended Properties=""Excel 12.0 Xml;HDR=YES"";"
      
      
        Set conn = CreateObject("ADODB.Connection")
        conn.Open sConnString
      
      
        If conn.State = 1 Then
            MsgBox "Bağlandı " & sFileName
            Exit Do
        End If
      
    
        conn.Close
        Set conn = Nothing
        sFileName = Dir()
    Loop
  

    If conn Is Nothing Then
        MsgBox sFolder & " İÇİNDE BAĞLANTI KURULAMADI!! "
    End If
End Sub

 

[tahsinanarat]

Sn. @Korhan Ayhan hocam, denedim ancak sonuç alamadım.
Sn. @beab05 bağlıntı kuruldu, dosya adını mesaj olarak verdi, ancak sorguyu kendimce denedim fakat nereye yazacağımı bilemedim.
sorgum;
Sorgu = "Select F1,F2,F3,F13,F7,F8,F9,F10,F11 from [Girdi$A2:AA1000000]"

 

[Korhan Ayhan]

@tahsinanarat,

En son önerilen koddaki dosya adı ile benim önerimdeki kodun aynı sonucu vermersi gerekir. Sonuçta değişken kullanılarak dosya yolu ve adı tespit edilmiş. Benim öneriminde aynı sonucu vermesi gerekir diye düşünüyorum.

 

[tahsinanarat]

Sub Girdi_guncelle()
Sheets("Sheet1").Select
If Date >= CDate("31/5/2023") Then Exit Sub

Range("A2:az65000").ClearContents
Set con = CreateObject("Adodb.Connection"): Set rs = CreateObject("Adodb.RecordSet")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & _
"C:\Users\tomson\Desktop\01_OCAK_2023_Stok\" & Dir("C:\Users\tomson\Desktop\01_OCAK_2023_Stok\1000 Malzeme_Stok_Takip*") & ";extended properties=""excel 12.0;hdr=no;imex=1"""


Sorgu = "Select F1,F2,F3,F13,F7,F8,F9,F10,F11  from [Girdi$A2:AA1000000]"

rs.Open Sorgu, con, 1, 1
Range("a2").CopyFromRecordset rs

rs.Close: con.Close
Set con = Nothing: Set rs = Nothing: Sorgu = Empty
ActiveSheet.Columns("A:AA").EntireColumn.AutoFit
On Error Resume Next
Range("b1").Select
End Sub

Sn. @korhan Hocam, bu seferki denememde oldu, pc adını değiştirmeden deniyordum herhalde, işyerindeki ile evdeki pc adları farklı. Çok teşekkür ederim. Hayırlı geceler.