- Katılım
- 20 Ekim 2005
- Mesajlar
- 476
sevgili haluk üstadın ado ile veri alma makrolarını kendime uyarlamaya çalıştım ama bir türlü beceremedim.
C nin içinde bulunan Demirbaş klasörünün içindeki Demirbaş.xls dosyasından a1:l1200 arası verileri listboxa birtürlü yüklemiyor ve
The source file or source range invalid hatası veriyor.
Dim NewSh
'
Const SourceFile As String = "C:\Demirbaş\Demirbaş.xls"
Const SourceSheet As String = "Sayfa11"
Const SourceRange As String = "A1:L1200"
'
Private Sub CommandButton1_Click()
Dim MyArr
Dim Start As Double, Finnish As Double
Start = Timer
If SheetExists("DataSheet") = True Then
Application.DisplayAlerts = False
Sheets("DataSheet").Delete
Application.DisplayAlerts = True
End If
Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
NewSh.Name = "DataSheet"
NewSh.Visible = False
Call GetDataFromClosedWorkbook(SourceFile, SourceRange)
ListBox1.ColumnCount = 5
MyArr = Sheets("DataSheet").Range("A1:E5000").Value
ListBox1.List = MyArr
Application.DisplayAlerts = False
NewSh.Delete
Application.DisplayAlerts = True
Finnish = Timer
MsgBox "ListBox is loaded in " & Format(Finnish - Start, "00") & " seconds !"
End Sub
'
Private Sub GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String)
Dim dbConnection As Object, rs As Object
Dim dbConnectionString As String
Set dbConnection = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.recordset")
Dim TargetCell As Range, i As Integer
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"ReadOnly=1;DBQ=" & SourceFile
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString
Set rs = dbConnection.Execute("[" & SourceSheet & "$" & SourceRange & "]")
Set TargetCell = NewSh.Cells(1, 1)
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "The source file or source range is invalid!", vbExclamation
End Sub
'
Private Function SheetExists(sname) As Boolean
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
End If
End Function
kodlarda düzelme yapan arkadaşlara şimdiden teşekkürler
C nin içinde bulunan Demirbaş klasörünün içindeki Demirbaş.xls dosyasından a1:l1200 arası verileri listboxa birtürlü yüklemiyor ve
The source file or source range invalid hatası veriyor.
Dim NewSh
'
Const SourceFile As String = "C:\Demirbaş\Demirbaş.xls"
Const SourceSheet As String = "Sayfa11"
Const SourceRange As String = "A1:L1200"
'
Private Sub CommandButton1_Click()
Dim MyArr
Dim Start As Double, Finnish As Double
Start = Timer
If SheetExists("DataSheet") = True Then
Application.DisplayAlerts = False
Sheets("DataSheet").Delete
Application.DisplayAlerts = True
End If
Set NewSh = Sheets.Add(After:=Sheets(Sheets.Count))
NewSh.Name = "DataSheet"
NewSh.Visible = False
Call GetDataFromClosedWorkbook(SourceFile, SourceRange)
ListBox1.ColumnCount = 5
MyArr = Sheets("DataSheet").Range("A1:E5000").Value
ListBox1.List = MyArr
Application.DisplayAlerts = False
NewSh.Delete
Application.DisplayAlerts = True
Finnish = Timer
MsgBox "ListBox is loaded in " & Format(Finnish - Start, "00") & " seconds !"
End Sub
'
Private Sub GetDataFromClosedWorkbook(SourceFile As String, SourceRange As String)
Dim dbConnection As Object, rs As Object
Dim dbConnectionString As String
Set dbConnection = CreateObject("ADODB.Connection")
Set rst = CreateObject("ADODB.recordset")
Dim TargetCell As Range, i As Integer
dbConnectionString = "DRIVER={Microsoft Excel Driver (*.xls)};" & _
"ReadOnly=1;DBQ=" & SourceFile
On Error GoTo InvalidInput
dbConnection.Open dbConnectionString
Set rs = dbConnection.Execute("[" & SourceSheet & "$" & SourceRange & "]")
Set TargetCell = NewSh.Cells(1, 1)
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "The source file or source range is invalid!", vbExclamation
End Sub
'
Private Function SheetExists(sname) As Boolean
Dim x As Object
On Error Resume Next
Set x = ActiveWorkbook.Sheets(sname)
If Err = 0 Then
SheetExists = True
Else
SheetExists = False
End If
End Function
kodlarda düzelme yapan arkadaşlara şimdiden teşekkürler
