AccessTr.neT

Sayfalar: 1 2 3 4 5 6

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.

konunuz excelde olduğu için taşımıştır

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

(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





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

(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....

Sayfalar: 1 2 3 4 5 6

HORZUM

berduş

feraz

HORZUM

feraz

HORZUM