(04/11/2020, 17:21)berduş yazdı: tarih alanı verileri hangi sütundan alıyor?
bu arada aşağıdaki kodu 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")
syfForum.Range("A2:F" & Rows.Count).ClearContents
Application.ScreenUpdating = False
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, format(cdate(F19),'dd.mm.yyyy') & ' ' & 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
Debug.Print ADO_RS.RecordCount
syfForum.Range("a2").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
SQL = "SELECT F6, format(cdate(F19),'dd.mm.yyyy') & ' ' & F7, F2 & '-' & F3, F12, F4 "
SQL = Sql & vbCrLf
SQL = Sql & "FROM [Veri$" & "] where F13='Yabancı Araç Plakasına' ;"
Yukarıdaki kodu alttaki gibi değiştiriseniz hem kod kısalır hemde toplam tutar sayısal olur abey.
Kod bendede çalıştı.
SQL = "SELECT F6, format(cdate(F19),'dd.mm.yyyy') & ' ' & F7, F2 & '-' & F3, F12, cdbl(F4) "
SQL = Sql & "FROM [Veri$] where F13='Yabancı Araç Plakasına' ;"
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
Zaman bulunca kodu inceleyim dedim hatalı yazmışım 5.mesajdaki kodu.
Doğrusu alttaki gibi olacak yani arr(i,1) gibi yerlerdeki i yerine say gelecekti
Koduda değiştiririm birazdan.
Ayrıca formatlamalarınıda yapıp tamamını eklerim kodun.
If LCase(veri(i, 13)) = "yabancı araç plakasına" Then
say = say + 1
arr(say, 1) = veri(i, 6)
arr(say, 2) = veri(i, 19) & " " & veri(i, 7)
arr(say, 3) = veri(i, 2) & " " & veri(i, 3)
arr(say, 4) = veri(i, 12)
arr(say, 5) = veri(i, 4)
End If
Kodun en son hali alttadır.
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(CStr(veri(i, 13))) = "yabancı araç plakasına" Then
say = say + 1
arr(say, 1) = veri(i, 6)
arr(say, 2) = Format(veri(i, 19), "dd.mm.yyyy") & " " & Format(CStr(veri(i, 7)), "hh:mm")
arr(say, 3) = veri(i, 2) & "-" & veri(i, 3)
arr(say, 4) = veri(i, 12)
arr(say, 5) = veri(i, 4)
End If
Next
Application.ScreenUpdating = True
If say > 0 Then
syfForum.Range("A2").Resize(say, 5).Value = arr
MsgBox "Akrarma Tamam...", vbInformation, "Aktarma"
End If
End With
GoTo son2
son:
MsgBox "Akrarma Basarisiz...", vbExclamation, "Aktarma"
son2:
Set syfForum = Nothing: Erase arr: Erase veri
End Sub
cdbl(F4) yerine ccur(F4) yazsak olur mu?
Kusura bakmayin bilgisayar olmadigindan deneyemedim.
(04/11/2020, 23:05)berduş yazdı: cdbl(F4) yerine ccur(F4) yazsak olur mu?
Kusura bakmayin bilgisayar olmadigindan deneyemedim.
Olabilir benim bildiğim ccur parabirimine çeviriyor.Eğer ingilizce
Excel kullanılırsa dolar işareti çıkması gerek kendi bilgisayarımda bir deneyetim normalde € çıkması gerek bende.
O alan Toplam ceza tutarinin olduğu alan ise para turunden olmasi daha uygun olur diye düşündüm genelde
ofis kurulurken bulundugumuz ulkeyi secmissek sorun yok ama dediginiz gibi yerel ayarlardaki para birimi farkliysa sorun cikabilir.