(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

Kodu Seç

Kodu Kopyala

---

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

Kodu Seç

Kodu Kopyala

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

Rica ederim.

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

(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

Kodu Seç

Kodu Kopyala

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