Secilen kapali dosyadan veri alma

[TRUSA]

Arkadaslar Merhaba,

Bu mesaji yazmadan once uzun bir sure forumda arama yaptim ve degisik sekillerde denedim fakat bir turlu beceremedim. Simdi yardimlarinizi bekliyorum..

Kapali bir dosyadan istedigim verileri alip acik olan dosyama kopyalayabiliyorum. Fakat kapali olan dosya ismi acik olan dosyamda yazmis oldugum haftaya gore olmali. Yani W200730, W200731, W200732 gibi kapali dosyalarim var. Ben acik olan dosyamda tarih girip haftayi buluyorum. Butona bastigimda ise hafta 31 ise W200731 dosyasindaki verileri almak istiyorum. Asagida macronun adres yolunun oldugu kismi gonderiyorum. Kisaca W200732 kismindaki 32 rakamini nasil degisken yapabiliriz ? Her defasinda macroya girip W200730, W200731 gibi degistirmemek icin...

Dim NewSh
Const SourceFile As String = "P:\RIDVAN\Haftalik_Uretim_Plani\W200732.XLS"
Const SourceSheet As String = "Sheet1"
Const SourceRange As String = "A1:AH300"

Yardimlariniz ve paylasimlariniz icin simdiden tesekkurler..

 

[TRUSA]

Arkadaslar yardimlarinizi bekliyorum...

 

[Recep İpek]

Const SourcePath As String = "P:\RIDVAN\Haftalik_Uretim_Plani\"
Const SourceSheet As String = "Sheet1"
Const SourceRange As String = "A1:AH300"

Sub Bağlan()
SourceFile = SourcePath & "W2007" & [a1] & ".xls"
MsgBox SourceFile
End Sub

şeklinde kullanabilirsiniz.

 

[TRUSA]

Sayin ripek,

Sabahtan beri bekledigim cevabin icin ne kadar tesekkur etsem azdir.. Fakat yazmis oldugunuz komutu nerede va nasil kullanacagimi beceremedim. Bir kez daha yardiminizi esirgemezseniz minnettar kalacagim..Asagida kullandigim kodlarin tamamini yaziyorum...


Dim NewSh
Const SourceFile As String = "E:\Haftalik_Uretim_Plani\W200732.XLS"
Const SourceSheet As String = "Sheet1"
Const SourceRange As String = "A1:AH300"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Sheets("Sheet1").Range("A1:AH300").ClearContents
Call GetDataFromClosedWorkbook(SourceFile, SourceRange)
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 = Sheets("Sheet1").Range("A1")
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "Aranýlan dosya bulunamadý!", vbExclamation
End Sub

Sub Baglan()
SourceFile = SourcePath & "W2007" & [D2] & ".xls"
MsgBox SourceFile
End Sub

 

[Recep İpek]

Kodlarınızı aşağıdaki şekilde deneyebilirmisiniz?

Dim NewSh
Const SourceFile As String = "E:\Haftalik_Uretim_Plani\"......
Const SourceSheet As String = "Sheet1"
Const SourceRange As String = "A1:AH300"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Sheets("Sheet1").Range("A1:AH300").ClearContents
SourceFile = SourcePath & "W2007" & [D2] & ".xls"
Call GetDataFromClosedWorkbook(SourceFile, SourceRange)
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 = Sheets("Sheet1").Range("A1")
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "Aranýlan dosya bulunamadý!", vbExclamation
End Sub

 

[TRUSA]

Sayin ripek,

Sizin yazmis oldugunuzu denedim fakat bold yazdiginiz satirda hata veriyor.

Hata Mesaji:
Assignment to constant not permitted

Tesekkur ederim.

 

[Recep İpek]

Pardon,

Const SourceFile As String = "E:\Haftalik_Uretim_Plani\"......

satırını

Const SourcePath As String = "E:\Haftalik_Uretim_Plani\"......

olarak değiştiriniz.

 

[TRUSA]

Sayin ripek,

Uzgunum..

Call GetDataFromClosedWorkbook(SourceFile, SourceRange)

satirindaki, SourceFile komutunda hata veriyor..

Hata Mesaji:
ByRef argument type mismatch

Cok tesekkur ederim alakaniza..

 

[TRUSA]

Sayin ripek,

Const SourceFile As String = "E:\Haftalik_Uretim_Plani\W2007" & 32 & ".xls"

seklinde yaziyorum sorunsuz calisiyor.

Tesekkurler..

 

[Recep İpek]

Bende

Const SourceFile As String = "E:\Haftalik_Uretim_Plani\W2007" & [a1] & ".xls"

şeklinde denemiştim ama hata vermişti.Neyse bu şekilde de güzel.Çalıştığına sevindim.

 

[TRUSA]

Tekrar Gunaydin Sayin ripek,

Ne kadar ugrastiginizin farkindayim. Cok tesekkur ederim. Fakat sorunum cozulmedi.

Const SourceFile As String = "E:\Haftalik_Uretim_Plani\W2007" & [a1] & ".xls"
seklinde yapiyorum olmuyor.

Const SourceFile As String = "E:\Haftalik_Uretim_Plani\W2007" & 32 & ".xls"
olarak yapiyorum sorunsuz calisiyor. Buradaki 32 rakamini degisken yapmak istiyorum. Amacim su; sheet icine girmis oldugum tarih otomatik olarak haftayi buluyor ve bu rakamda haftayi gosteriyor. Ilgili haftaya ait W200730, W200731 gibi dosyalardan istedigim datalari almasini istiyorum.

Yardimlarin ve paylasimciligin icin tesekkurler..

 

[Recep İpek]

Aşağıdaki kodları deneyiniz.

Dim NewSh
Const SourcePath As String = "E:\Haftalik_Uretim_Plani\"
Const SourceSheet As String = "Sheet1"
Const SourceRange As String = "A1:AH300"
Public SourceFile As String

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Sheets("Sheet1").Range("A1:AH300").ClearContents
SourceFile = SourcePath & "W2007" & [a1] & ".xls"
Call GetDataFromClosedWorkbook(SourceFile, SourceRange)
Cancel = True
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 = Sheets("Sheet1").Range("A1")
TargetCell.CopyFromRecordset rs
rs.Close
dbConnection.Close
Set TargetCell = Nothing
Set rs = Nothing
Set dbConnection = Nothing
On Error GoTo 0
Exit Sub
InvalidInput:
MsgBox "Aranılan dosya bulunamadı!", vbExclamation
End Sub

 

[TRUSA]

Gunaydin sayin ripek,

Gonderdiginiz kodlari uyguladim ve su anda tam istedigim gibi mukemmel calisiyor.

Alakaniz, paylasimciliginiz ve sabriniz icin ne kadar tesekkur etsem azdir...