• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

kapalı dosya yolu

B

bunyaming

Altın Üye
Katılım
13 Ocak 2017
Mesajlar
158
Excel Vers. ve Dili
2010 türkçe
Merhaba,

ado ile kapalı access dosyasından veri alıyorum.
yalnız dosyayı mail attığımda başka bilgisayarda dosya yolunu değiştirmeden çalışmıyor
aşağıda ki kodu nasıl düzenlemeliyim diğer kişilerde de otomatik çalışması için
teşekkürler

Const constraccess As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= C:\Users\bunyaming\Desktop\RAPOR SORGULA\Database221.accdb;Persist Security Info=False;"
 
Merhaba;
Sub masaüstü_yolu()
Set masaüstü = CreateObject("WScript.Shell")
masaüstüyolu = masaüstü.SpecialFolders("Desktop")
MsgBox masaüstüyolu
End Sub

masaüstüyolu değişkenini sorgulamanızda kullanabilirsiniz
 
muygun' Alıntı:
Merhaba;
Sub masaüstü_yolu()
Set masaüstü = CreateObject("WScript.Shell")
masaüstüyolu = masaüstü.SpecialFolders("Desktop")
MsgBox masaüstüyolu
End Sub

masaüstüyolu değişkenini sorgulamanızda kullanabilirsiniz
Genişletmek için tıkla ...
teşekkürler sayın Muygun
fakat ben çalıştıramadım
aşağıda ki gibi en üstte sabit tanım olarak duruyor ve çalışmıyor
örneklere de baktım hep bu şekil ama ben bir yerde hata yapıyorum bulamadım
Option Explicit
Const constraccess As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.Path & "\RAPOR SORGULA\Database221.accdb;Persist Security Info=False;"
 
Option Explicit
Bu satırı silp deneyiniz.:cool:
 
Orion1' Alıntı:
Option Explicit
Bu satırı silp deneyiniz.:cool:
Genişletmek için tıkla ...
Merhaba Evren Bey,
yine aynı yerde hata veriyor.Path kısmında imleç yanıp sönüyor
" & ThisWorkbook.Path & "\RAPOR SORGULA
rapor sorgula klasörün adı
fakat başka bilgisayara mail attığımda dosyaya orada manuel olarak dosya yolunu tekrar yapıştırmam gerekiyor.
attığım bilgisayarda çalıştığında otomatik yolu belirlesin istiyorum
kodun tamamı aşağıda ki gibidir.Dosya da özel bilgiler olduğundan paylaşamıyorum

Option Explicit
Const constraccess As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= C:\Users\bunyaming\Desktop\RAPOR SORGULA\Database221.accdb;Persist Security Info=False;"
Sub datacek()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim moviesconn As ADODB.Connection
Dim moviesdata As ADODB.Recordset
Dim moviesfield As ADODB.Field
Dim ws As Worksheet
Set ws = Sheets("sheet1")
ws.Range("a1:AT1500").Clear
Set moviesconn = New ADODB.Connection
Set moviesdata = New ADODB.Recordset

moviesconn.ConnectionString = constraccess
moviesconn.Open


With moviesdata
.ActiveConnection = moviesconn
.Source = "TRANSFORM count([AY]) AS İfade1 SELECT Bunyas.LOKASYON, count([100 Mal Girisi]) AS [T SEFER]FROM Bunyas WHERE Varis='" & Range("AU1") & "' GROUP BY Bunyas.LOKASYON ORDER BY Bunyas.SIRA ASC PIVOT Bunyas.SIRA;"

.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With




For Each moviesfield In moviesdata.Fields
ActiveCell.Value = moviesfield.Name
ActiveCell.Offset(0, 1).Select
Next moviesfield


ws.Range("a1").Select
ws.Range("A2").CopyFromRecordset moviesdata


If Cells(1, 3) = "1" Then Cells(1, 3).Value = "Ocak"
If Cells(1, 4) = "2" Then Cells(1, 4).Value = "Şubat"
If Cells(1, 5) = "3" Then Cells(1, 5).Value = "Mart"
If Cells(1, 6) = "4" Then Cells(1, 6).Value = "Nisan"
If Cells(1, 7) = "5" Then Cells(1, 7).Value = "Mayıs"
If Cells(1, 8) = "6" Then Cells(1, 8).Value = "Haziran"
If Cells(1, 9) = "7" Then Cells(1, 9).Value = "Temmuz"
If Cells(1, 10) = "8" Then Cells(1, 10).Value = "Ağustos"
If Cells(1, 11) = "9" Then Cells(1, 11).Value = "Eylül"
If Cells(1, 12) = "10" Then Cells(1, 12).Value = "Ekim"
If Cells(1, 13) = "11" Then Cells(1, 13).Value = "Kasım"
If Cells(1, 14) = "12" Then Cells(1, 14).Value = "Aralık"

Call Makro1
Call Makro3
moviesdata.Close
moviesconn.Close


Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
 
bunyaming' Alıntı:
Merhaba Evren Bey,
yine aynı yerde hata veriyor.Path kısmında imleç yanıp sönüyor
" & ThisWorkbook.Path & "\RAPOR SORGULA
rapor sorgula klasörün adı
fakat başka bilgisayara mail attığımda dosyaya orada manuel olarak dosya yolunu tekrar yapıştırmam gerekiyor.
attığım bilgisayarda çalıştığında otomatik yolu belirlesin istiyorum
kodun tamamı aşağıda ki gibidir.Dosya da özel bilgiler olduğundan paylaşamıyorum

Option Explicit
Const constraccess As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= C:\Users\bunyaming\Desktop\RAPOR SORGULA\Database221.accdb;Persist Security Info=False;"
Sub datacek()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim moviesconn As ADODB.Connection
Dim moviesdata As ADODB.Recordset
Dim moviesfield As ADODB.Field
Dim ws As Worksheet
Set ws = Sheets("sheet1")
ws.Range("a1:AT1500").Clear
Set moviesconn = New ADODB.Connection
Set moviesdata = New ADODB.Recordset

moviesconn.ConnectionString = constraccess
moviesconn.Open


With moviesdata
.ActiveConnection = moviesconn
.Source = "TRANSFORM count([AY]) AS İfade1 SELECT Bunyas.LOKASYON, count([100 Mal Girisi]) AS [T SEFER]FROM Bunyas WHERE Varis='" & Range("AU1") & "' GROUP BY Bunyas.LOKASYON ORDER BY Bunyas.SIRA ASC PIVOT Bunyas.SIRA;"

.LockType = adLockReadOnly
.CursorType = adOpenForwardOnly
.Open
End With




For Each moviesfield In moviesdata.Fields
ActiveCell.Value = moviesfield.Name
ActiveCell.Offset(0, 1).Select
Next moviesfield


ws.Range("a1").Select
ws.Range("A2").CopyFromRecordset moviesdata


If Cells(1, 3) = "1" Then Cells(1, 3).Value = "Ocak"
If Cells(1, 4) = "2" Then Cells(1, 4).Value = "Şubat"
If Cells(1, 5) = "3" Then Cells(1, 5).Value = "Mart"
If Cells(1, 6) = "4" Then Cells(1, 6).Value = "Nisan"
If Cells(1, 7) = "5" Then Cells(1, 7).Value = "Mayıs"
If Cells(1, 8) = "6" Then Cells(1, 8).Value = "Haziran"
If Cells(1, 9) = "7" Then Cells(1, 9).Value = "Temmuz"
If Cells(1, 10) = "8" Then Cells(1, 10).Value = "Ağustos"
If Cells(1, 11) = "9" Then Cells(1, 11).Value = "Eylül"
If Cells(1, 12) = "10" Then Cells(1, 12).Value = "Ekim"
If Cells(1, 13) = "11" Then Cells(1, 13).Value = "Kasım"
If Cells(1, 14) = "12" Then Cells(1, 14).Value = "Aralık"

Call Makro1
Call Makro3
moviesdata.Close
moviesconn.Close


Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub
Genişletmek için tıkla ...
merhaba,

yardımcı olabilecek değerli üstadlarım

halen çözüm bulamadım

teşekkürler

aynı klasör farklı bilgisayarda dosya yoluna müdahele etmeden çalışması için uğraşıyorum
 
Merhaba
Kodların içinde tanımlamayı denedinizmi?
Kod: 
Sub datacek()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim moviesconn As ADODB.Connection
Dim moviesdata As ADODB.Recordset
Dim moviesfield As ADODB.Field
Dim ws As Worksheet
'...........
Dim constraccess As String
constraccess = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= " & ThisWorkbook.Path & "\RAPOR SORGULA\Database221.accdb;Persist Security Info=False;"
'..........
Set ws = Sheets("sheet1")
ws.Range("a1:AT1500").Clear
Set moviesconn = New ADODB.Connection
Set moviesdata = New ADODB.Recordset
 
PLİNT' Alıntı:
Merhaba
Kodların içinde tanımlamayı denedinizmi?
Kod: 
Sub datacek()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual

Dim moviesconn As ADODB.Connection
Dim moviesdata As ADODB.Recordset
Dim moviesfield As ADODB.Field
Dim ws As Worksheet
'...........
Dim constraccess As String
constraccess = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source= " & ThisWorkbook.Path & "\RAPOR SORGULA\Database221.accdb;Persist Security Info=False;"
'..........
Set ws = Sheets("sheet1")
ws.Range("a1:AT1500").Clear
Set moviesconn = New ADODB.Connection
Set moviesdata = New ADODB.Recordset
Genişletmek için tıkla ...
Teşekkürler Sayın Plint
ayrı ayrı yazıp database olan yere kadar düzenleyince çalıştı
sağolun
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst