AccessTr.neT

Bul · 04/11/2020, 14:18

(04/11/2020, 13:56)HORZUM yazdı:

(04/11/2020, 12:52)feraz yazdı: Örnek dosyanızda sütundakiler demiştiniz.İf koşulu ekledim diz olarak.
ilk koduda ayarlarım.Hata olursa koddaki Tr karakterlerini düzeltin.

Sub Aktar()

    Dim syfForum As Worksheet, arr(), veri(), say As Long

    Dim i As Long, son As Long, sonVer As Long

    Set syfForum = ThisWorkbook.Sheets("Form")

    

    say = 0

    With ThisWorkbook.Sheets("Veri")

        syfForum.Range("A2:F" & Rows.Count).ClearContents

        son = .Cells(Rows.Count, "M").End(3).Row

        If son < 2 Then son = 2

        If WorksheetFunction.CountA(.Range("M2:M" & Rows.Count)) = 0 Then GoTo son

        Application.ScreenUpdating = False

        veri = .Range("A2:S" & son).Value

        ReDim arr(1 To son, 1 To 19)

        For i = LBound(veri) To UBound(veri)

             If LCase(veri(i, 13)) = "yabancý araç plakasýna" Then

                say = say + 1

                arr(i, 1) = veri(i, 6)

                arr(i, 2) = veri(i, 19) & " " & veri(i, 7)

                arr(i, 3) = veri(i, 2) & " " & veri(i, 3)

                arr(i, 4) = veri(i, 12)

                arr(i, 5) = veri(i, 4)

            End If

        Next

        If say > 0 Then

            syfForum.Range("A2").Resize(say, 5).Value = arr

            MsgBox "Akrarma Tamam...", vbInformation, "Aktarma"

        End If

        Application.ScreenUpdating = True

    End With

    GoTo son2

son:

    MsgBox "Akrarma Basarisiz...", vbExclamation, "Aktarma"

son2:

    Set syfForum = Nothing: Erase arr: Erase veri

End Sub

Buda ilk kodun düzenlenmiş hali.

Sub Aktar2()

    Dim syfForum As Worksheet, say As Long

    Dim i As Long, son As Long

    Set syfForum = ThisWorkbook.Sheets("Form")

    say = 2

    syfForum.Range("A2:F" & Rows.Count).ClearContents

    With ThisWorkbook.Sheets("Veri")

        son = .Cells(Rows.Count, "M").End(3).Row

        If son < 2 Then son = 2

        If WorksheetFunction.CountA(.Range("M2:M" & Rows.Count)) = 0 Then GoTo son

        Application.ScreenUpdating = False

        For i = 2 To son

            If LCase(.Cells(i, "M").Value) = "yabancý araç plakasýna" Then

                syfForum.Cells(say, 1).Value = .Cells(i, "F").Value

                syfForum.Cells(say, 2).Value = .Cells(i, "S").Value & " " & .Cells(i, "G").Value

                syfForum.Cells(say, 3).Value = .Cells(i, "B").Value & "-" & .Cells(i, "C").Value

                syfForum.Cells(say, 4).Value = .Cells(i, "L").Value

                syfForum.Cells(say, 5).Value = .Cells(i, "D").Value

                say = say + 1

            End If

        Next

        If say > 2 Then

            MsgBox "Akrarma Tamam...", vbInformation, "Aktarma"

        Else

            MsgBox "Akrarilacak veri bulunamadi...", vbExclamation, "Aktarma"

        End If

        Application.ScreenUpdating = True

    End With

    GoTo son2

son:

    MsgBox "Akrarma Basarisiz...", vbExclamation, "Aktarma"

son2:

    Set syfForum = Nothing

End Sub

ÇOOKKK TEŞEKKÜR EDERİM....

Rica ederim.

Bul · 04/11/2020, 16:24

sayın @HORZUM alternatif olarak aşağıdaki kodu da dener misiniz?

Sub Aktar()



    Dim syfForum As Worksheet

    Dim i As Long, son As Long, sonVer As Long

    Set syfForum = ThisWorkbook.Sheets("Form")

   

    With ThisWorkbook.Sheets("Veri")

        son = .Cells(Rows.Count, "M").End(3).Row

        If son < 2 Then son = 2

        If WorksheetFunction.CountA(.Range("M2:M" & Rows.Count)) = 0 Then GoTo son

        Application.ScreenUpdating = False

            sonVer = syfForum.Range("A" & Rows.Count).End(3)(2, 1).Row

    

Dim Sql As String

Dim ADO_CN As Object

Dim ADO_RS As Object



Set ADO_CN = CreateObject("Adodb.Connection")

Set ADO_RS = CreateObject("adodb.recordset")



SQL = "SELECT F6, cdate(F19) & ' ' & F7, F2 & '-' & F3, F12, F4  "

SQL = Sql & vbCrLf

SQL = Sql & "FROM [Veri$" & "] where F13='Yabancı Araç Plakasına' ;"



ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _

";extended properties=""excel 8.0;hdr=no;imex=1"""

ADO_CN.Open

ADO_RS.Open SQL, ADO_CN, 3, 1

'

'   Eğer Hiç Kayıt Yoksa

    If ADO_RS.RecordCount = 0 Then

        ADO_RS.Close

        ADO_CN.Close

        Set ADO_RS = Nothing

        Set ADO_CN = Nothing

        MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"

        Exit Sub

    End If

ADO_RS.movelast

ADO_RS.movefirst

  syfForum.Range("a" & sonVer).CopyFromRecordset ADO_RS



ADO_RS.Close

ADO_CN.Close

Set ADO_RS = Nothing

Set ADO_CN = Nothing



        MsgBox "Akrarma Tamam...", vbInformation, "Aktarma"

        Application.ScreenUpdating = True

    End With

    GoTo son2

son:

    MsgBox "Akrarma Basarisiz...", vbExclamation, "Aktarma"

son2:

    Set syfForum = Nothing

End Sub

Bul · 04/11/2020, 16:39

(04/11/2020, 16:24)berduş yazdı: syfForum.Range("A" & Rows.Count).End(3)(2, 1).Row

Ben kodu denemedim lakin istenene göre A2 den itibaren kodlar veri aktaracak.Oysa bu kod enson dolu satırın bir alt satırını verir Img-grin

Bu arada Ado ya bazen güvenmemek gerek excelde Img-grin

Bul · 04/11/2020, 16:42

zaten kod onu yapmıyor mu? kastettiğiniz ne?

kod form sayfasındaki ilk boş satıra gidip verileri ekliyor
denemelerimde ilk 3 satırda veri oldğundan 4. satırdan itibaren yapıştırdı verileri

Bul · 04/11/2020, 16:52

(04/11/2020, 16:42)berduş yazdı: zaten kod onu yapmıyor mu? kastettiğiniz ne?

kod form sayfasındaki ilk boş satıra gidip verileri ekliyor
denemelerimde ilk 3 satırda veri oldğundan 4. satırdan itibaren yapıştırdı verileri

İlk boş satıra eklenmeyecek.Saydaki veriler 2.satırdan itibaren temizlenecek.ve 2.satırdan itibaren bulunanlar eklenecek.Bunda anlaşılmayacak bişey yok abey Img-grin

Çünkü üstad doğru demişti son verdiğim koda orda dediğim gibi yapmıştım.

Bul · 04/11/2020, 17:02

(04/11/2020, 16:24)berduş yazdı: sayın @HORZUM alternatif olarak aşağıdaki kodu da dener misiniz?

Sub Aktar()



    Dim syfForum As Worksheet

    Dim i As Long, son As Long, sonVer As Long

    Set syfForum = ThisWorkbook.Sheets("Form")

   

    With ThisWorkbook.Sheets("Veri")

        son = .Cells(Rows.Count, "M").End(3).Row

        If son < 2 Then son = 2

        If WorksheetFunction.CountA(.Range("M2:M" & Rows.Count)) = 0 Then GoTo son

        Application.ScreenUpdating = False

            sonVer = syfForum.Range("A" & Rows.Count).End(3)(2, 1).Row

    

Dim Sql As String

Dim ADO_CN As Object

Dim ADO_RS As Object



Set ADO_CN = CreateObject("Adodb.Connection")

Set ADO_RS = CreateObject("adodb.recordset")



SQL = "SELECT F6, cdate(F19) & ' ' & F7, F2 & '-' & F3, F12, F4  "

SQL = Sql & vbCrLf

SQL = Sql & "FROM [Veri$" & "] where F13='Yabancı Araç Plakasına' ;"



ADO_CN.ConnectionString = "provider=Microsoft.ACE.OLEDB.12.0;data source=" & ThisWorkbook.FullName & _

";extended properties=""excel 8.0;hdr=no;imex=1"""

ADO_CN.Open

ADO_RS.Open SQL, ADO_CN, 3, 1

'

'   Eğer Hiç Kayıt Yoksa

    If ADO_RS.RecordCount = 0 Then

        ADO_RS.Close

        ADO_CN.Close

        Set ADO_RS = Nothing

        Set ADO_CN = Nothing

        MsgBox "Kayıt Bulunamadı.", vbCritical, "Veri Yok"

        Exit Sub

    End If

ADO_RS.movelast

ADO_RS.movefirst

  syfForum.Range("a" & sonVer).CopyFromRecordset ADO_RS



ADO_RS.Close

ADO_CN.Close

Set ADO_RS = Nothing

Set ADO_CN = Nothing



        MsgBox "Akrarma Tamam...", vbInformation, "Aktarma"

        Application.ScreenUpdating = True

    End With

    GoTo son2

son:

    MsgBox "Akrarma Basarisiz...", vbExclamation, "Aktarma"

son2:

    Set syfForum = Nothing

End Sub

BERDUŞ BEY TEŞEKKÜRLER. TARİH GELMİYOR. TARİHİ "gg.aa.yyyy ss:dd"OLARAK YAPABİLİRMİYİZ

AccessTr.neT

Veri Aktarma

Veri Aktarma

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Giriş yap

Hesap oluştur

Konu Linkleri