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ı: 6)
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.

Visual Basic Code
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 Adlı Kullanıcıdan Alıntı: Merhaba.
Alttakibi deneyin.Eğer veriniz çoksa ve yavaş çalışırsa dizi yöntemi ilede yapılır.

Visual Basic Code
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

Visual Basic Code
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.

Visual Basic Code
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

Son Düzenleme: 04/11/2020, 12:57, Düzenleyen: feraz. (Sebep: Kod düzenlendi.i yerlerine say yazıldı arr() içine)
Cevapla
#6
(04/11/2020 12:52)feraz Adlı Kullanıcıdan Alıntı: Örnek dosyanızda sütundakiler demiştiniz.İf koşulu ekledim dizi olarak.
ilk koduda ayarlarım.Hata olursa koddaki Tr karakterlerini düzeltin.

Visual Basic Code
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.

Visual Basic Code
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