Skip to main content

AccessTr.neT

Kayıt Ol

 | Facebook ile Bağlan  | Twitter İle Bağlan | Google+ İle Bağlan

Veri Aktarma

HORZUM
HORZUM
Excel Cevaplanmış Soruları
35
3885

Veri Aktarma

Çözüldü #1
HORZUM
Aktif Üye
HORZUM
Bul
Aktif Üye
Adı Soyadı: BE.... HO....
Yaşı: 53
Konum: Burdur
Ofis Versiyonu: Ofis 2016 64 Bit
Son Oturumu: 17/01/2025,16:15
Yorumları: 93
Konuları: 21
Kayıt Tarihi: 22/12/2010
Teşekkür Puanı: 0
Mesleğiniz: MEMUR
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
berduş
Berduş
berduş
Bul
Uzman
Adı Soyadı: ha....
Konum: -
Ofis Versiyonu: Ofis 2019 64 Bit
Son Oturumu: Bugün,19:45
Yorumları: 8.506
Konuları: 94
Kayıt Tarihi: 30/07/2014
Teşekkür Puanı: 1.051
konunuz excelde olduğu için taşımıştır
Cevapla
#3
feraz
Uzman
feraz
Bul
Uzman
Adı Soyadı: Za....
Yaşı: 47
Konum: -
Ofis Versiyonu: Diğer
Son Oturumu: 28/07/2024,00:46
Yorumları: 3.642
Konuları: 95
Kayıt Tarihi: 30/03/2013
Teşekkür Puanı: 316
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
HORZUM
Aktif Üye
HORZUM
Bul
Aktif Üye
Adı Soyadı: BE.... HO....
Yaşı: 53
Konum: Burdur
Ofis Versiyonu: Ofis 2016 64 Bit
Son Oturumu: 17/01/2025,16:15
Yorumları: 93
Konuları: 21
Kayıt Tarihi: 22/12/2010
Teşekkür Puanı: 0
Mesleğiniz: MEMUR
(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
feraz
Uzman
feraz
Bul
Uzman
Adı Soyadı: Za....
Yaşı: 47
Konum: -
Ofis Versiyonu: Diğer
Son Oturumu: 28/07/2024,00:46
Yorumları: 3.642
Konuları: 95
Kayıt Tarihi: 30/03/2013
Teşekkür Puanı: 316 




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
HORZUM
Aktif Üye
HORZUM
Bul
Aktif Üye
Adı Soyadı: BE.... HO....
Yaşı: 53
Konum: Burdur
Ofis Versiyonu: Ofis 2016 64 Bit
Son Oturumu: 17/01/2025,16:15
Yorumları: 93
Konuları: 21
Kayıt Tarihi: 22/12/2010
Teşekkür Puanı: 0
Mesleğiniz: MEMUR
(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