Veri Aktarma

1 2 3 4 5 6

(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.

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

(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 Bu arada Ado ya bazen güvenmemek gerek excelde

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

(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 Çünkü üstad doğru demişti son verdiğim koda orda dediğim gibi yapmıştım.

(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

1 2 3 4 5 6