Skip to main content

AccessTr.neT


Verileri Kritere Göre Başka Sayfaya Aktarmak

Verileri Kritere Göre Başka Sayfaya Aktarmak

Çözüldü #1
Veri satırları aşağıya doğru uzamaktadır.
Verileri  Kriter olarak Sonuç başlığında DEVAM EDEN satırları Liste sayfasına H başlığına göre 1.Grup, 2.Grup ve 3.Grup a göre sıralatmak istiyorum. Veri aralığı değişmektedir. Son veriyi baz alarak işlem yapılabilir mi?
Veri sayfasından verileri Veri süze göre alıp liste sayfasında sıralatabilirim ama macro ile işi kolay bir şekilde tıkladığım zaman aktarsın istiyorum. Liste sayfasından da farklı bir şablona göre otomatik yazdırma yapacağım. Yardımcı olan arkadaşlara teşekkür ederim.
.rar Kritere Göre Veri Aktarımı 2021.rar (Dosya Boyutu: 62,92 KB | İndirme Sayısı: 1)
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#2
Kod altta abey.

Sub Aktar()

Dim son As Long, i As Long, say As Long, k As Byte
Dim veri
Dim syfVeri As Worksheet
Dim syfListe As Worksheet

Set syfVeri = ThisWorkbook.Worksheets("Veri")
Set syfListe = ThisWorkbook.Worksheets("Liste")

With syfVeri
    son = .Range("A" & Rows.Count).End(3).Row + 1
    veri = .Range("A2:j" & son).Value
   
    ReDim arr(1 To son, 1 To UBound(veri, 2))
   
    For i = LBound(veri) To UBound(veri)
        If LCase(veri(i, 9)) = "devam eden" Then
          say = say + 1
            For k = 1 To UBound(veri, 2)
                arr(say, k) = veri(i, k)
            Next
        End If
    Next
End With

syfListe.Range("C2:L" & Rows.Count).ClearContents

If say > 0 Then
    syfListe.Range("C2").Resize(say, UBound(veri, 2)).Value = arr
    syfListe.Range("C2").Resize(say, UBound(veri, 2)).Sort syfListe.Range("j2"), xlAscending, , , , , , xlNo
End If

MsgBox "Bitti"
On Error Resume Next
Erase veri: Erase arr
Set syfVeri = Nothing
Set syfListe = Nothing
End Sub
.rar Kritere Göre Veri Aktarımı 2021.rar (Dosya Boyutu: 74,61 KB | İndirme Sayısı: 5)
Cevapla
#3
Sayın feraz bey çok sağolun aktarma işlemi gayet başarılı. Acaba veri sayfasında J sütununu da Liste sayfasına veri aktarmaya dahil etsek kodda nereyi değiştirmeliyiz.
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Son Düzenleme: 10/08/2021, 11:07, Düzenleyen: yyhy. (Sebep: yazım imla hatası düzeltme.)
Cevapla
#4
Bişey değil abey.
Resimdeki gibi J sütunu aktarıyor.

[Resim: do.php?img=11177]
https://resim.accesstr.net/do.php?img=11177
Cevapla
#5
Sayın feraz bey Veri sayfasındaki j sütununu Liste sayfasına aktarmak istiyorum.

https://dosya.co/8qn3snhq7e53/J_sütunu.jpg.html
yyhy, 18-05-2009 tarihinden beri AccessTr.neT üyesidir.
Cevapla
#6
Abey önceki kodda aktarıyordu.
Alttaki kodu deneyin birde.
Kod:
Const sonSutun As Byte = 10 'J sütun
burdaki 10 yazanı 11 yaparsanız K sütununa kadar olur örneğin.

Sub Aktar()

Dim son As Long, i As Long, say As Long, k As Byte
Dim veri
Dim syfVeri As Worksheet
Dim syfListe As Worksheet

Const sonSutun As Byte = 10 'J sütun

Set syfVeri = ThisWorkbook.Worksheets("Veri")
Set syfListe = ThisWorkbook.Worksheets("Liste")

With syfVeri
    son = .Range("A" & Rows.Count).End(3).Row + 1
    veri = .Range("A2", .Cells(son, sonSutun)).Value
   
    ReDim arr(1 To son, 1 To sonSutun)
   
    For i = LBound(veri) To UBound(veri)
        If LCase(veri(i, 9)) = "devam eden" Then
          say = say + 1
            For k = 1 To sonSutun
                arr(say, k) = veri(i, k)
            Next
        End If
    Next
End With

syfListe.Range("C2:L" & Rows.Count).ClearContents

If say > 0 Then
    syfListe.Range("C2").Resize(say, sonSutun).Value = arr
    syfListe.Range("C2").Resize(say, sonSutun).Sort syfListe.Cells(2, sonSutun), xlAscending, , , , , , xlNo
End If

MsgBox "Bitti"
On Error Resume Next
Erase veri: Erase arr
Set syfVeri = Nothing
Set syfListe = Nothing
End Sub
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task