AccessTr.neT
Verileri Kritere Göre Başka Sayfaya Aktarmak - Baskı Önizleme

+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Verileri Kritere Göre Başka Sayfaya Aktarmak (/konu-verileri-kritere-gore-baska-sayfaya-aktarmak.html)

Sayfalar: 1 2


Verileri Kritere Göre Başka Sayfaya Aktarmak - yyhy - 09/08/2021

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.


RE: Verileri Kritere Göre Başka Sayfaya Aktarmak - feraz - 10/08/2021

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



RE: Verileri Kritere Göre Başka Sayfaya Aktarmak - yyhy - 10/08/2021

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.


RE: Verileri Kritere Göre Başka Sayfaya Aktarmak - feraz - 10/08/2021

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


RE: Verileri Kritere Göre Başka Sayfaya Aktarmak - yyhy - 10/08/2021

Sayın feraz bey Veri sayfasındaki j sütununu Liste sayfasına aktarmak istiyorum.

https://dosya.co/8qn3snhq7e53/J_sütunu.jpg.html


RE: Verileri Kritere Göre Başka Sayfaya Aktarmak - feraz - 10/08/2021

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