- Katılım
- 26 Ekim 2010
- Mesajlar
- 14
- Excel Vers. ve Dili
- Ofis 2003
Merhabalar..
Forumda kapalı dosyalara veri aktarmayı ararken aşağıdaki Evren Gizlen hocaya ait kodları buldum.Makrolar hakkında fazla bilgim olmadığından kendi dosyama uyarlayamadım."D" deki DEPO isimli bir klasörde bulunan KALIP isimli tek sayfa excel çalışma kitabından yine daha önceden forumdam temin ettiğim;
Sub YEDEK_OLUŞTUR()
Dim Dosya_Yolu As String
Dim Dosya_Adı As String
Application.DisplayAlerts = False
Dosya_Yolu = "D:\DEPO\"
Dosya_Adı = Range("A1") & " " & Format(Now, " ") & ".xls"
ActiveWorkbook.SaveAs (Dosya_Yolu & Dosya_Adı)
MsgBox "Yedekleme işlemi tamamlanmıştır.", vbInformation
If Excel.Application.Windows.Count = 1 Then
Else
End If
End Sub
kodu ile A1 hücresindeki değişen isme göre isim alan çalışma kitablarını aynı klasöre aktarıyorum.DEPO klasöründe 20 veya 30 civarında çalışma kitabı oluşuyor.
Aşağıdaki Evren Gizlen hocaya ait bu kodları KALIP isimli sayfadaki "A1" hücresindeki değişen değere göre değiştirirseniz çok sevinirim..Teşekkürler.
Sub kapaliye_aktar()
'Tools referanslardan Microsoft activex Dataobjext 2.8 library seçildi
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
conn.Open ("Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path _
& "\BELGELER.xls;extended properties=""excel 8.0;hdr=yes""")
rs.Open "select * from [EK-7$];", conn, adOpenDynamic, adLockOptimistic
rs.AddNew
rs("ADI SOYADI").Value = Range("C6").Value
rs("KAYIT SINIFI").Value = Range("C4").Value
rs("CİNSİ").Value = Range("J5").Value
rs("YER").Value = Range("J7").Value
rs.Update
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
MsgBox "Veriler Başarı ile BELGELER.xls Dosyasına kaydedildi." & vbLf & _
vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
Forumda kapalı dosyalara veri aktarmayı ararken aşağıdaki Evren Gizlen hocaya ait kodları buldum.Makrolar hakkında fazla bilgim olmadığından kendi dosyama uyarlayamadım."D" deki DEPO isimli bir klasörde bulunan KALIP isimli tek sayfa excel çalışma kitabından yine daha önceden forumdam temin ettiğim;
Sub YEDEK_OLUŞTUR()
Dim Dosya_Yolu As String
Dim Dosya_Adı As String
Application.DisplayAlerts = False
Dosya_Yolu = "D:\DEPO\"
Dosya_Adı = Range("A1") & " " & Format(Now, " ") & ".xls"
ActiveWorkbook.SaveAs (Dosya_Yolu & Dosya_Adı)
MsgBox "Yedekleme işlemi tamamlanmıştır.", vbInformation
If Excel.Application.Windows.Count = 1 Then
Else
End If
End Sub
kodu ile A1 hücresindeki değişen isme göre isim alan çalışma kitablarını aynı klasöre aktarıyorum.DEPO klasöründe 20 veya 30 civarında çalışma kitabı oluşuyor.
Aşağıdaki Evren Gizlen hocaya ait bu kodları KALIP isimli sayfadaki "A1" hücresindeki değişen değere göre değiştirirseniz çok sevinirim..Teşekkürler.
Sub kapaliye_aktar()
'Tools referanslardan Microsoft activex Dataobjext 2.8 library seçildi
Dim conn As ADODB.Connection, rs As ADODB.Recordset
Set conn = New ADODB.Connection
Set rs = New ADODB.Recordset
conn.Open ("Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path _
& "\BELGELER.xls;extended properties=""excel 8.0;hdr=yes""")
rs.Open "select * from [EK-7$];", conn, adOpenDynamic, adLockOptimistic
rs.AddNew
rs("ADI SOYADI").Value = Range("C6").Value
rs("KAYIT SINIFI").Value = Range("C4").Value
rs("CİNSİ").Value = Range("J5").Value
rs("YER").Value = Range("J7").Value
rs.Update
rs.Close
Set rs = Nothing
conn.Close
Set conn = Nothing
MsgBox "Veriler Başarı ile BELGELER.xls Dosyasına kaydedildi." & vbLf & _
vbLf & "evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub