• DİKKAT

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

Hata Oluştuğunda Mesaj Gösterme

B

BedriA

Katılım
3 Haziran 2017
Mesajlar
797
Excel Vers. ve Dili
2007, 32
Arkadaşlar,

Açık iki excel dosyası arasında veri aktarımı yapabiliyorum. Ancak veri alacağım excel dosyası kapalıyken hata veriyor. Bu hata oluştuğunda mesaj vermesi için uğraştım ama beceremedim. Kod aşağıdaki gibidir.

Şimdiden teşekkür ederim.

Kod: 
Private Sub CommandButton15_Click()
 
Son_Dolu_Satir = ActiveSheet.Range("A65536").End(3).Row
 
Bos_Satir = Son_Dolu_Satir + 1
ActiveSheet.Range("A" & Bos_Satir).Value = _
Application.WorksheetFunction.Max(ActiveSheet.Range("A:A")) + 1
    
    
    Windows("liste.xlsx").Activate
    Range("A2:C65536").Select
    Selection.Copy
    Windows("PEN.xlsm").Activate
    Range("A" & Bos_Satir).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
  
 
End Sub
 
Boş satırdan sonra on error resume goto hata yazın.end Sub dan önce de hata: msgbox "Mesaj" yazın.
 
askm' Alıntı:
Boş satırdan sonra on error resume goto hata yazın.end Sub dan önce de hata: msgbox "Mesaj" yazın.
Genişletmek için tıkla ...

Teşekkür ederim.
Bu şekilde hata önleniyor ama buna rağmen listeye mesajdan sonra "1" yazıyor. Tekrar basarsan bu defa mesajdan sonra "2" geliyor, bu böyle sürüyor.
 
Siz kapalı dosyadan veri çekmeye çalışıyorsanız örnek dosyanızı eklerseniz daha kolay yardımcı olunur.
 
askm' Alıntı:
Siz kapalı dosyadan veri çekmeye çalışıyorsanız örnek dosyanızı eklerseniz daha kolay yardımcı olunur.
Genişletmek için tıkla ...

Dosya açıkken sorunsuz çekiyor veriyi. Kapalıyken ise hata veriyordu. Dediğiniz eklemeleri yapınca hata yerine mesaj göstermeye başladı ancak buna rağmen veritabanına rakam atıyor.
 
Siz A sütununa öncelikle sıra numarası verip sonra aynı hücreye farklı çalışma kitabından veri çekiyorsunuz. Yapmak istediğinizi tam olarak anlayamadım ki.Aşağıdaki kodu f8 ile çalıştırın. hata nerde veriyor. ona bakalım.
Kod: 
Private Sub CommandButton15_Click()
 
Son_Dolu_Satir = ActiveSheet.Range("A65536").End(3).Row
Bos_Satir = Son_Dolu_Satir + 1
'on error resume next ' burada hata verirse bir sonraki aşamaya geç demektir.f8 ile çalıştırdıktan sonra en baştakı tek tırnağı kaldırıp deneyin.
ActiveSheet.Range("A" & Bos_Satir).Value = _
Application.WorksheetFunction.Max(ActiveSheet.Range("A:A")) + 1
    
    
    Windows("liste.xlsx").Activate
    Range("A2:C65536").Select
    Selection.Copy
    Windows("PEN.xlsm").Activate
    Range("A" & Bos_Satir).Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
  
 
End Sub
 
Kod: 
Private Sub CommandButton15_Click()

Burası sarıya boyandı f8 ile çalıştırınca.
 
Örnek dosyanızı ekleyebilir misiniz.Orası daha kodun başlangıç kısmı orada hata vermesi enteresan. Dilerseniz özelden de atabilirsiniz dosyanızı.
 
Dosya ektedir. Özetle sorun şu: veritabanı ve liste dosyaları açıkken sorunsuz veri aktarımı yapıyor. Ancak veritabanı açık, liste açık değilse hata veriyor ve veritabanının a sütununa rakamlar atıyor.

dosyalar açık veya kapalı fark etmez, hata vermeden aktarım yapmak istiyorum.

İlginiz için teşekkür ederim.
 

Ekli dosyalar

Aşağıdaki gibi kullanabilirsiniz. Yalnız kodunuzda bir hatalı işlem var.

A sütunundaki boş satırı buluyor. Sonra o hücreye sıra no veriyor. Aynı zamanda liste sayfasındaki verileri bu numara verdiği hücrenin üzerine yapıştırıyor. Bu durumda sıra numarasının bir önemi kalmıyor.

Kod: 
Private Sub CommandButton1_Click()
    Dim K1 As Workbook
    Son_Dolu_Satir = ActiveSheet.Range("A65536").End(3).Row
    Bos_Satir = Son_Dolu_Satir + 1
    ActiveSheet.Range("A" & Bos_Satir).Value = Application.WorksheetFunction.Max(ActiveSheet.Range("A:A")) + 1
 
    On Error Resume Next
    Set K1 = Workbooks("liste.xlsx")
    On Error GoTo 0
    If K1 Is Nothing Then
        Set K1 = Workbooks.Open(ThisWorkbook.Path & "\liste.xlsx", 0, 0)
    Else
        Windows("liste.xlsx").Activate
    End If
    Range("A2:C65536").Select
    Selection.Copy
    Windows("veritabanı.xlsm").Activate
    Range("A" & Bos_Satir).Select
    ActiveSheet.Paste
End Sub
 
Koda ufak bir ilave yapmak istiyorum.
Kod: 
Private Sub CommandButton1_Click()
Dim K1 As Workbook
Son_Dolu_Satir = ActiveSheet.Range("A65536").End(3).Row
 Bos_Satir = Son_Dolu_Satir + 1
 ActiveSheet.Range("A" & Bos_Satir).Value = _
 Application.WorksheetFunction.Max(ActiveSheet.Range("A:A")) + 1

On Error Resume Next
 Set K1 = Workbooks("liste.xlsx")
 On Error GoTo 0
If K1 Is Nothing Then
    Set K1 = Workbooks.Open(ThisWorkbook.Path & "\liste.xlsx", 0, 0)
Else
    Windows("liste.xlsx").Activate
End If
    
    Range("A2:C65536").Select
    Selection.Copy
    Windows("veritabanı.xlsm").Activate
    Range("A" & Bos_Satir).Select
    ActiveSheet.Paste
Application.DisplayAlerts = False

K1.Close
Windows("veritabanı.xlsm").Activate
End Sub
 
Bu da alternatif ado ile aktarım.
Kod: 
Sub askm_aktar()
Dim conn As Object, rs As Object, sonsat As Long
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("Adodb.recordset")
dosya = ThisWorkbook.Path & "\liste.xlsx"
Application.ScreenUpdating = False
    conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & _
            dosya & ";extended properties=""excel 12.0;hdr=no""")
    rs.Open "select * from [Sayfa1$A2:C65000];", conn, 1, 1
    If rs.RecordCount > 0 Then
        sonsat = Cells(Rows.Count, "B").End(xlUp).Row
        Range("A" & sonsat + 1).CopyFromRecordset rs
        
    End If
    rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
Range("A1:C65000").HorizontalAlignment = xlCenter
Range("A1:C65000").VerticalAlignment = xlCenter

MsgBox "Veriler aktarıldı." & vbLf & "ASKM"
End Sub
 
Korhan Ayhan' Alıntı:
Aşağıdaki gibi kullanabilirsiniz. Yalnız kodunuzda bir hatalı işlem var.

A sütunundaki boş satırı buluyor. Sonra o hücreye sıra no veriyor. Aynı zamanda liste sayfasındaki verileri bu numara verdiği hücrenin üzerine yapıştırıyor. Bu durumda sıra numarasının bir önemi kalmıyor.

Kod: 
Private Sub CommandButton1_Click()
    Dim K1 As Workbook
    Son_Dolu_Satir = ActiveSheet.Range("A65536").End(3).Row
    Bos_Satir = Son_Dolu_Satir + 1
    ActiveSheet.Range("A" & Bos_Satir).Value = Application.WorksheetFunction.Max(ActiveSheet.Range("A:A")) + 1
 
    On Error Resume Next
    Set K1 = Workbooks("liste.xlsx")
    On Error GoTo 0
    If K1 Is Nothing Then
        Set K1 = Workbooks.Open(ThisWorkbook.Path & "\liste.xlsx", 0, 0)
    Else
        Windows("liste.xlsx").Activate
    End If
    Range("A2:C65536").Select
    Selection.Copy
    Windows("veritabanı.xlsm").Activate
    Range("A" & Bos_Satir).Select
    ActiveSheet.Paste
End Sub
Genişletmek için tıkla ...


Kodları kes-yapıştır-revize etmeye çalış yöntemiyle kullanmaya çalışınca böyle gereksiz işlemlere mahal veriyor işte. Zamanla öğreneceğiz Korhan Hoca.

Çok teşekkür ederim.
 
askm' Alıntı:
Bu da alternatif ado ile aktarım.
Kod: 
Sub askm_aktar()
Dim conn As Object, rs As Object, sonsat As Long
Set conn = CreateObject("adodb.connection")
Set rs = CreateObject("Adodb.recordset")
dosya = ThisWorkbook.Path & "\liste.xlsx"
Application.ScreenUpdating = False
    conn.Open ("provider=microsoft.ace.oledb.12.0;data source=" & _
            dosya & ";extended properties=""excel 12.0;hdr=no""")
    rs.Open "select * from [Sayfa1$A2:C65000];", conn, 1, 1
    If rs.RecordCount > 0 Then
        sonsat = Cells(Rows.Count, "B").End(xlUp).Row
        Range("A" & sonsat + 1).CopyFromRecordset rs
        
    End If
    rs.Close: conn.Close
Set rs = Nothing: Set conn = Nothing
Application.ScreenUpdating = True
Range("A1:C65000").HorizontalAlignment = xlCenter
Range("A1:C65000").VerticalAlignment = xlCenter

MsgBox "Veriler aktarıldı." & vbLf & "ASKM"
End Sub
Genişletmek için tıkla ...

İlginiz ve emeğiniz için çok teşekkür ederim.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst