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