Skip to main content

AccessTr.neT


Veri Aktarma

Veri Aktarma

Çözüldü #1
Ekli dosyadaki form kısmına sadece veri kısmındaki Yabancı Araç Plakasına sütunlarındaki verileri nasıl aktarabilirim. Kod ile aktarma yapılır ise daha iyi olacak...
Formülde olsa olur.
.rar Yabancı.rar (Dosya Boyutu: 10,87 KB | İndirme Sayısı: 8)
Cevapla
#2
konunuz excelde olduğu için taşımıştır
Cevapla
#3
Merhaba.
Alttakibi deneyin.Eğer veriniz çoksa ve yavaş çalışırsa dizi yöntemi ilede yapılır.

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
        For i = 2 To son
            sonVer = syfForum.Range("A" & Rows.Count).End(3)(2, 1).Row
            syfForum.Cells(sonVer, 1).Value = .Cells(i, "F").Value
            syfForum.Cells(sonVer, 2).Value = .Cells(i, "S").Value & " " & .Cells(i, "G").Value
            syfForum.Cells(sonVer, 3).Value = .Cells(i, "B").Value & "-" & .Cells(i, "C").Value
            syfForum.Cells(sonVer, 4).Value = .Cells(i, "L").Value
            syfForum.Cells(sonVer, 5).Value = .Cells(i, "D").Value
        Next
        MsgBox "Akrarma Tamam...", vbInformation, "Aktarma"
        Application.ScreenUpdating = True
    End With
    GoTo son2
son:
    MsgBox "Akrarma Basarisiz...", vbExclamation, "Aktarma"
son2:
    Set syfForum = Nothing
End Sub
Cevapla
#4
(04/11/2020, 12:27)feraz yazdı: Merhaba.
Alttakibi deneyin.Eğer veriniz çoksa ve yavaş çalışırsa dizi yöntemi ilede yapılır.

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
        For i = 2 To son
            sonVer = syfForum.Range("A" & Rows.Count).End(3)(2, 1).Row
            syfForum.Cells(sonVer, 1).Value = .Cells(i, "F").Value
            syfForum.Cells(sonVer, 2).Value = .Cells(i, "S").Value & " " & .Cells(i, "G").Value
            syfForum.Cells(sonVer, 3).Value = .Cells(i, "B").Value & "-" & .Cells(i, "C").Value
            syfForum.Cells(sonVer, 4).Value = .Cells(i, "L").Value
            syfForum.Cells(sonVer, 5).Value = .Cells(i, "D").Value
        Next
        MsgBox "Akrarma Tamam...", vbInformation, "Aktarma"
        Application.ScreenUpdating = True
    End With
    GoTo son2
son:
    MsgBox "Akrarma Basarisiz...", vbExclamation, "Aktarma"
son2:
    Set syfForum = Nothing
End Sub
FERUZ BEY AKTARMA YAPTI. AMA HEPSİNİ AKTARIYOR. SADECE"Yabancı Araç Plakasına" OLANI AKTARACAK
Cevapla
#5


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

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
Cevapla
#6
(04/11/2020, 12:52)feraz yazdı: Örnek dosyanızda sütundakiler demiştiniz.İf koşulu ekledim dizi 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(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
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....
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task