Kapalı dosyadan veri alma(BU BAŞKA)

[burcin_end_muh]

Merhaba arkadaşlar,
Öncelikle bu konuyu iyice araştırdığımı ve bulduğum bu linklerin uygun olmadığını gördüm:
http://www.excel.web.tr/f48/kapaly-excelden-macro-ile-du-eyara-ile-veri-t140359.html#post762326

http://www.excel.web.tr/f117/kapaly-dosyadan-d-eyara-vlookup-kullanymy-t864.html

http://www.excel.web.tr/f50/birden-ok-kapaly-excel-dosyasyndan-veri-alma-t126674.html

http://www.excel.web.tr/f48/kapaly-dosyalardan-veri-alma-makrosunda-deoi-iklik-t140301.html

bu çalışmalar uygun değil çünkü hepsinin başlık satırları gayet düzenli. Şirketimizin kullandığı ERP programı dataları excele alırken başlıkları tek hücre değil birleştirme yaparak alıyor bu da düşeyara bile yapamamama neden oluyor.

şimdi derdimi tam olarak açıklayacak olursam bir klasör içine erp den aldığım excel data dosyalarım var. xls olarak kaydediyor. birtane de form dosyam var. Dataları bu forma cekiyorum düşeyarayla.

Eğer veri dosyalarımı açıp dosya-dönüştür(uyumluluk modu) dersem dataları değiştirip kaydedip kapattığımda form dosyasını actıgımda verileri guncelliyor. ama xls olan dosya verilerini guncellemıyor.

Benım ıstegım bı klasor ıcındekı xls dosyalarını acıp donustur yapman bı makro. dosya adlarını acmadan xlsx olarak degıstırınce olmuyor.

yada alternatıf ne yapılabılır? bu arada forma ılk basta baska dosyadan dırek hcreyı cagırdım ama sonradan ogrendım kı o gun o markadan satıs yoksa adı baslıkta cıkmıyor yanı hucre cagırmıs olsam satırlar kaymıs oluyor.

Umarım derdımı dogru olarak anlatabılmısımdır sımdıden tesekkurler.

EN KOTU IHTIMALLE HER DOSYAYI ACIP DONUSTUR DIYIP KAPATACAGIM EN SON FORM DOSYAM GUNCELLENECEK :/

 

[algerian]

Merhaba,
Aynı sorundan ben de muzdaribim. ".xls" uzantılı dosya içerisinden kapalı iken data çekemiyorum. Dosyayı hiç bulamamış gibi hata veriyor. Ne yaptıysam olmadı. Eğer dosyayı açıp ".xlsx" uzantılı olarak farklı kaydedip tekrar kapatırsam oluyor, ancak sistem her saat başı aynı dosya üzerine kaydetme şeklinde data dosyası oluşturduğu için, anlık güncel datadan mahrum kalıyorum.
Kapalı haldeki ".xls" uzantılı dosyadan, aktif çalıştığım ".xlsx" uzantılı dosyaya veri çekebilecek bir makroya ihtiyacım var.
Bu konuda yardımcı olabilecek ustalarıma şimdiden teşekkür ederim.

 

[Erdem Akdemir]

Bağlantı kodlarınızı paylaşabilir misiniz?

Aşağıdaki kod bütün excel versiyonlarına bağlanabilir.

Provider=Microsoft.ACE.OLEDB.12.0;Data Source=c:\myFolder\myExcel2007file.xlsx;
Extended Properties="Excel 12.0 Xml;HDR=YES";

 

[algerian]

Selam,
Kapalı dosyadan data çekmek için aşağıdaki Functions modülü kodlarını kullanıyorum. Bahsettiğiniz kodlar içerisinde mevcut, ancak işe yaramıyor. Excel 2007 versiyonda kaydedilmiş ".xls" uzantılı dosyadan Excel 2013 versiyonda kaydedilmiş ".xlsx" uzantılı dosyaya data alamıyorum.

Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
                   SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, [COLOR="Red"]working in Excel 2000-2007[/COLOR]
    Dim rsCon As Object
    Dim rsData As Object
    Dim szConnect As String
    Dim szSQL As String
    Dim lCount As Long

    ' Create the connection string.
    If Header = False Then
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=No"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=No"";"
        End If
    Else
        If Val(Application.Version) < 12 Then
            szConnect = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 8.0;HDR=Yes"";"
        Else
            szConnect = "Provider=Microsoft.ACE.OLEDB.12.0;" & _
                        "Data Source=" & SourceFile & ";" & _
                        "Extended Properties=""Excel 12.0;HDR=Yes"";"
        End If
    End If

    If SourceSheet = "" Then
        ' workbook level name
        szSQL = "SELECT * FROM " & SourceRange$ & ";"
    Else
        ' worksheet level name or range
        szSQL = "SELECT * FROM [" & SourceSheet$ & "$" & SourceRange$ & "];"
    End If

    On Error GoTo SomethingWrong

    Set rsCon = CreateObject("ADODB.Connection")
    Set rsData = CreateObject("ADODB.Recordset")

    rsCon.Open szConnect
    rsData.Open szSQL, rsCon, 0, 1, 1

    ' Check to make sure we received data and copy the data
    If Not rsData.EOF Then

        If Header = False Then
            TargetRange.Cells(1, 1).CopyFromRecordset rsData
        Else
            'Add the header cell in each column if the last argument is True
            If UseHeaderRow Then
                For lCount = 0 To rsData.Fields.Count - 1
                    TargetRange.Cells(1, 1 + lCount).Value = _
                    rsData.Fields(lCount).Name
                Next lCount
                TargetRange.Cells(2, 1).CopyFromRecordset rsData
            Else
                TargetRange.Cells(1, 1).CopyFromRecordset rsData
            End If
        End If

    Else
        MsgBox "No records returned from : " & SourceFile, vbCritical
    End If

    ' Clean up our Recordset object.
    rsData.Close
    Set rsData = Nothing
    rsCon.Close
    Set rsCon = Nothing
    Exit Sub

SomethingWrong:
    MsgBox "The file name, Sheet name or Range is invalid of : " & SourceFile, _
           vbExclamation, "Error"
    On Error GoTo 0

End Sub

Makro kodları da aşağıdaki şekildedir:

Sub getir()
    Dim SaveDriveDir As String, MyPath As String
    Dim FName As Variant
    Application.ScreenUpdating = False
    Sheets("PackageTasks").Visible = True
    
    Sheets("PackageTasks").Select
    Range("A2:S" & Rows.Count).ClearContents
    SaveDriveDir = CurDir
    MyPath = "U:\PP\Bakimlar\OPEN"
    ChDrive MyPath
    ChDir MyPath
    FName = ("PackageTasks.xlsx")
    If FName = False Then
        'do nothing
    Else
        GetData FName, "PackageTasks", "A2:S" & Rows.Count, Sheets("PackageTasks").Range("A2"), False, False
    End If

   
    ChDrive SaveDriveDir
    ChDir SaveDriveDir
    

    Sheets("PackageTasks").Visible = False
    Sheets("pivot").Select
    Application.ScreenUpdating = True
End Sub

Function SAYFA(SAYFAADI As String) As Boolean
    On Error Resume Next
    SAYFA = CBool(Len(Worksheets(SAYFAADI).Name) > 0)
End Function

 

[algerian]

Yukarıdaki mesajda

FName = ("PackageTasks.[COLOR="Red"]xlsx[/COLOR]")

şeklinde olan dosya adını

FName = ("PackageTasks.[COLOR="red"]xls[/COLOR]")

şeklinde kullanmam gerekiyor, ancak dosya bulunamadı hatası veriyor.

 

[algerian]

Sayın kuvari, inceleme imkanı bulabildiniz mi?

 

[Erdem Akdemir]

Merhaba,

Aşağıdaki bağlantı yolu da işinizi görecektir.

Dosyaları da ekleyebilirseniz kontrol edebilirim.

Driver={Microsoft Excel Driver (*.xls, *.xlsx, *.xlsm, *.xlsb)};DBQ=C:\MyExcel.xlsx;