(04/11/2020, 13:56)HORZUM yazdı:Rica ederim.(04/11/2020, 12:52)feraz yazdı: Örnek dosyanızda sütundakiler demiştiniz.İf koşulu ekledim diz olarak.ÇOOKKK TEŞEKKÜR EDERİM....
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
Veri Aktarma
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
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
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?İ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
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
Çü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?BERDUŞ BEY TEŞEKKÜRLER. TARİH GELMİYOR. TARİHİ "gg.aa.yyyy ss:dd"OLARAK YAPABİLİRMİYİZ
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
Konuyu Okuyanlar: 1 Ziyaretçi
