Kapali dosyadan gelen bilgilerin otomatik guncellenmesi

[alphae]

Iyi aksamlar arkadaslar,

Kapali bir dosyadan VBA ile bilgileri istenilen dosyaya aktarabiliyorum. Sorun bunu dugme vasitasiyla degil de dakikada 1 sefer kendi kendini otomatik guncellemesi. Elinde kullandigim soyle bir guncelleme kodu var. Buna nasil entegre edebiliriz?

Sub AUTO_OPEN()
DoEvents
Application.OnTime Now + TimeValue("00:01:00"), "Yenile"

End Sub

Sub Yenile()
DoEvents
Application.CalculateFull
Workbooks("Grafiek.xlsm").RefreshAll
' ActiveWorkbook.RefreshAll
Application.OnTime Now + TimeValue("00:01:00"), "Yenile"
End Sub

Kapali dosya ornegi ise asagidaki linktedir.

http://www.speedyshare.com/SwbDg/test.rar

Simdiden tesekkurler

*Altin uyeligim olmadigi icin dosyayi nete yuklermisiniz ya da linki buraya kopyalayabilirsiniz.

 

[Emir Hüseyin Çoban]

. . .

Kodları boş bir modüle yapıştırın.
Tablonuzu kaydedip, kapatın. Yeniden açtığınızda çalışacaktır.

Sub GetData_Example1()
' It will copy the Header row also (the last two arguments are True)
' Change the last argument to False if you not want to copy the header row
    GetData ThisWorkbook.Path & "\data.xlsm", "sayfa1", _
            "A1:C50", Sheets("uygulama1").Range("A1"), True, True
    Call AUTO_OPEN
End Sub

Sub AUTO_OPEN()
    DoEvents
    Application.OnTime Now + TimeValue("00:01:00"), "GetData_Example1"
End Sub

. . .

 

[alphae]

cok tesekkur ederim

 

[alphae]

Yukarida belirtilen kodlar sorunsuz calisiyor. Kapali dosyadan aktarimda da sorun yasamiyorum fakat uygulama dosyasi ile data dosyasini ayni anda actigimda Run-time error '9'
Subscript out of range sorunu ile karsilasiyorum. asagida belirtilen bolum renkleniyor. Bu sorunu gidermenin bir caresi varmi?

GetData ThisWorkbook.Path & "\data.xlsm", "sayfa1", _
"A1:C50", Sheets("uygulama1").Range("A1"), True, True

Modul1 Macrosu:

Sub GetData_Example1()
' It will copy the Header row also (the last two arguments are True)
' Change the last argument to False if you not want to copy the header row
GetData ThisWorkbook.Path & "\data.xlsm", "sayfa1", _
"A1:C50", Sheets("uygulama1").Range("A1"), True, True
Call AUTO_OPEN
End Sub

Sub AUTO_OPEN()
DoEvents
Application.OnTime Now + TimeValue("00:00:10"), "GetData_Example1"
End Sub


Modul2 Macrosu:

Option Explicit


Public Sub GetData(SourceFile As Variant, SourceSheet As String, _
SourceRange As String, TargetRange As Range, Header As Boolean, UseHeaderRow As Boolean)
' 30-Dec-2007, working in Excel 2000-2007
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