• DİKKAT

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

Kapalı Dosyadan Veri alma

airborne

airborne

Katılım
20 Ekim 2005
Mesajlar
504
s.a.

Evren Gizlen Bey'in bir çalışmasından kapalı doyadan veri alma alma ile ilgili bu kodları buldum. asağıdaki kodlarda nasıl bir düzenleme yapılmalıdırki. kapalı dosyadan a1:b5;a7:b11;b13:b17 aralığını açık dosyanın a1:b5;a7:b11;b13:b17 aralığına aktarmak için kodda nasıl bir düzenleme yapılmalıdır.


Sub kapali_aktar()
Dim conn As Object, rs As Object
Set conn = CreateObject("AdoDb.Connection")
Set rs = CreateObject("AdoDb.Recordset")
conn.Open "Provider=microsoft.jet.oledb.4.0;data source=" & ThisWorkbook.Path & _
"\kapalı.xls;extended properties=""excel 8.0;hdr=yes"""
rs.Open "Select * from [Kapalı$];", conn, 1, 3
sat = Cells(65536, "A").End(xlUp).Row + 1
rs.movefirst
Range("A" & sat).CopyFromRecordset rs
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
MsgBox "Kapalı dosyadan veriler aktarıldı." & vbLf & _
"evrengizlen@hotmail.com", vbOKOnly + vbInformation, "E V R E N"
End Sub
 
. . .

Dosya dizini ekteki gibi olmalıdır. 2 excelde aynı klasör içinde olmalı.

Kod: 
Sub KOD()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\Kapalı.xls"
Workbooks.Open (yol)
Workbooks("Kapalı").Sheets("Sayfa1").Range("a1:b5").Copy _
Workbooks("Açık").Sheets("Sayfa1").Range("a1")

Workbooks("Kapalı").Sheets("Sayfa1").Range("a7:b11").Copy _
Workbooks("Açık").Sheets("Sayfa1").Range("a7")

Workbooks("Kapalı").Sheets("Sayfa1").Range("b13:b17").Copy _
Workbooks("Açık").Sheets("Sayfa1").Range("b13")

Workbooks("Kapalı").Close True

Application.ScreenUpdating = True
MsgBox " B i t t i "

End Sub

. . .
 

Ekli dosyalar

Dosyayı açmadan da aşağıdaki gibi olabilir:

Kod: 
Sub test()
    For Each r In Range("a1:b5,a7:b11,b3:b17")
        r.Value = Excel4(ThisWorkbook.Path & "\kapalı.xls", "kapalı", r.Row, r.Column)
    Next
End Sub

Private Function Excel4(dosya, sayfa, satir, sutun)
    d = Replace(dosya, Dir(dosya), "[" & Dir(dosya) & "]")
    Excel4 = ExecuteExcel4Macro("'" & d & sayfa & "'!R" & satir & "C" & sutun)
End Function
 
Zeki Gürsoy' Alıntı:
Dosyayı açmadan da aşağıdaki gibi olabilir:

Kod: 
Sub test()
    For Each r In Range("a1:b5,a7:b11,b3:b17")
        r.Value = Excel4(ThisWorkbook.Path & "\kapalı.xls", "kapalı", r.Row, r.Column)
    Next
End Sub

Private Function Excel4(dosya, sayfa, satir, sutun)
    d = Replace(dosya, Dir(dosya), "[" & Dir(dosya) & "]")
    Excel4 = ExecuteExcel4Macro("'" & d & sayfa & "'!R" & satir & "C" & sutun)
End Function
Genişletmek için tıkla ...


Zeki abi kod beni perişan etti.. kapalı.xls dosyasını bulamazsa klasör seçme ekranı açıyor..görev yöneticisinden kapatabildim..

bi problem de; aktaracağı açık olan dosyada ilgili hücreler "#başv" hatası veriyor..
 
Hüseyin Çoban' Alıntı:
. . .

Dosya dizini ekteki gibi olmalıdır. 2 excelde aynı klasör içinde olmalı.

Kod: 
Sub KOD()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\Kapalı.xls"
Workbooks.Open (yol)
Workbooks("Kapalı").Sheets("Sayfa1").Range("a1:b5").Copy _
Workbooks("Açık").Sheets("Sayfa1").Range("a1")

Workbooks("Kapalı").Sheets("Sayfa1").Range("a7:b11").Copy _
Workbooks("Açık").Sheets("Sayfa1").Range("a7")

Workbooks("Kapalı").Sheets("Sayfa1").Range("b13:b17").Copy _
Workbooks("Açık").Sheets("Sayfa1").Range("b13")

Workbooks("Kapalı").Close True

Application.ScreenUpdating = True
MsgBox " B i t t i "

End Sub

. . .
Genişletmek için tıkla ...

Hay Allah sizden razı olsun
 
s.a.

Hüseyin Çoban ustanın veri aktarım kodu hata verdi. Örnek doyam ektedir.Yardımcı olan üstadlardan ve,

Hepinizden Allah Razı Olsun.
 

Ekli dosyalar

selimcengizince' Alıntı:
Zeki abi kod beni perişan etti.. kapalı.xls dosyasını bulamazsa klasör seçme ekranı açıyor..görev yöneticisinden kapatabildim..

bi problem de; aktaracağı açık olan dosyada ilgili hücreler "#başv" hatası veriyor..
Genişletmek için tıkla ...

Ne olmasını bekliyordunuz ki? Dosya adı ve veri alınacak sayfa adı hatalı ise karşılacağınız durum bu olacaktır.

Prosedurun başında "Dir" fonksiyonu ile dosyanın varlığını kontrol ettirmenizde fayda var.
 
airborne' Alıntı:
s.a.
Hüseyin Çoban ustanın veri aktarım kodu hata verdi. Örnek doyam ektedir.Yardımcı olan üstadlardan ve,
Hepinizden Allah Razı Olsun.
Genişletmek için tıkla ...
. . .
Dosyanızdaki kodlar hatalı.
Aşağıdaki kodları deneyiniz, kırmızı işaretli yerlere dikkat. Dosyanızda bunlar hatalıydı.

Not: Alt tire sağa doğru uzayıp giden kod cümlelerinde bir alt satıra geçmek için kullanılır. Alt tireden bir önce ve sonra boşluk bırakılır. Çok uzun kod cümleleri bazen hata verebilir ve görünüm penceresi dışında kaldığı için kontrolü ve okunması zor olabilir. O yüzden alt satıra alınabilir.

Kod: 
Sub kapali_aktar()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\EK_DERS.xls"
Workbooks.Open (yol)
Workbooks("EK_DERS").Sheets("Puantaj").Range("L11:P70").Copy[COLOR="Red"][B] _[/B][/COLOR]
Workbooks("Açık").Sheets("Kapalı").Range("A2")
Workbooks("EK_DERS").Sheets("Puantaj").Range("AK11:AO70").Copy[COLOR="Red"][B] _[/B][/COLOR]
Workbooks("Açık").Sheets("Kapalı").Range("H2")
Workbooks("EK_DERS").Sheets("Puantaj").Range("BJ11:BN70").Copy[COLOR="Red"][B] _[/B][/COLOR]
Workbooks("Açık").Sheets("Kapalı").Range("O2")
Workbooks("EK_DERS").Sheets("Puantaj").Range("CI11:CM70").Copy[COLOR="Red"][B] _[/B][/COLOR]
Workbooks("Açık").Sheets("Kapalı").Range("v2")
Workbooks("EK_DERS").Sheets("Puantaj").Range("DH11:DL70").Copy[COLOR="Red"][B] _[/B][/COLOR]
Workbooks("Açık").Sheets("Kapalı").Range("AC2")
Workbooks("Açık").Sheets("Kapalı").Rows("8:10").Hidden = True
Workbooks("Açık").Sheets("Kapalı").Rows("17:19").Hidden = True
Workbooks("Açık").Sheets("Kapalı").Rows("26:28").Hidden = True
Workbooks("Açık").Sheets("Kapalı").Rows("35:37").Hidden = True
Workbooks("Açık").Sheets("Kapalı").Rows("44:46").Hidden = True
Workbooks("Açık").Sheets("Kapalı").Rows("53:56").Hidden = True
Workbooks[COLOR="Red"][B]("EK_DERS")[/B][/COLOR].Close True
Application.ScreenUpdating = True
MsgBox " B i t t i "

End Sub

veya bu şekilde de olabilir.

Kod: 
Workbooks("Kapalı").Sheets("Sayfa1").Range("a7:b11").Copy Workbooks("Açık").Sheets("Sayfa1").Range("a7")
 
Zeki Gürsoy' Alıntı:
Ne olmasını bekliyordunuz ki? Dosya adı ve veri alınacak sayfa adı hatalı ise karşılacağınız durum bu olacaktır.

Prosedurun başında "Dir" fonksiyonu ile dosyanın varlığını kontrol ettirmenizde fayda var.
Genişletmek için tıkla ...

Dosya yoksa veya adı yanlışsa, uyarı çıkmasını bekliyordum. "Dir" fonksiyonunu bilmiyorum araştırayım.

Abi dosya olunca da #BAŞV hatası veriyor. Nerde hata yapıyor olabilirim?
 
Hüseyin hocam sizin kodları aşağıdaki gibi kendime uyarladım. Ama RunTime Error 9 , Subscript out of range hatası alıyorum. Dosyalar aynı klasörde. Daha önce çalıştırdığım uyarlamayı şimdi yapamıyorum. :(

Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\kapalı.xlsm"
Workbooks.Open (yol)

Workbooks("kapalı").Sheets("Sayfa1").Range("J11:Y20").Copy _
Workbooks("açık").Sheets("Sayfa1").Range("A1")

Workbooks("kapalı").Close True
Application.ScreenUpdating = True
 

Ekli dosyalar

Son düzenleme:
excellcan' Alıntı:
Hüseyin hocam sizin kodları aşağıdaki gibi kendime uyarladım. Ama RunTime Error 9 , Subscript out of range hatası alıyorum. Dosyalar aynı klasörde. Daha önce çalıştırdığım uyarlamayı şimdi yapamıyorum. :(

Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\kapalı.xlsm"
Workbooks.Open (yol)

Workbooks("kapalı").Sheets("Sayfa1").Range("J11:Y20").Copy _
Workbooks("açık").Sheets("Sayfa1").Range("A1")

Workbooks("kapalı").Close True
Application.ScreenUpdating = True
Genişletmek için tıkla ...
. . .

Kodları çalıştıramadığınız örneği ekleyin. İnceleyelim.
Bu şekilde çözümlemek zor olur.
Kodları hangi sayfadan çalıştırdığınızı veya form kullanıp kullanmadığınız bu şekilde anlayamayız.

. . .
 
. . .

Eklediğiniz dosyada hata alıyor musunuz.
Bendeki işlem sonucu.

attachment.php


. . .
 

Ekli dosyalar

  • 1_01.jpg
    1_01.jpg
    73 KB · Görüntüleme: 246
Hocam sizde doğru çıkmış. Ama tekrar denedim. Aynı hatayı veriyor. :)
 
. . .

F8 ile kodları adım adım çalıştırın, hangi satırda hata veriyor. ::dusun:

. . .
 
Workbooks("açık").Sheets("Sayfa1").Range("A1")
Hocam bu satırda
 
. . .

Açık ve Kapalı tabloları içerisinde Sayfa1 sekmesi var değil mi ? Eminsiniz.

Kodlara ilave yaptım bu şekilde deneyiniz.

Kod: 
Private Sub CommandButton1_Click()
Application.ScreenUpdating = False
yol = ThisWorkbook.Path & "\kapalı.xlsm"
Workbooks.Open (yol)

[B]Workbooks("açık").Activate
Sheets("Sayfa1").Select
Range("A1").Select

Workbooks("kapalı").Sheets("Sayfa1").Range("J11:Y20").Copy Workbooks("açık").Sheets("Sayfa1").Range("A1")[/B]

Workbooks("kapalı").Close True
Application.ScreenUpdating = True
End Sub

. . .
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst