Kod:
Const gruplanacak_Sutun_Liste_Harf As String = "j"
Const devamEdenSutunHarf As String = "i"Birde klasik yavaş yöntemle eklerim tam anlarsınız.
Kodlar altta abey.
Sub Aktar()
Dim son As Long, i As Long, say As Long, k As Byte, m As Byte
Dim veri, devamedensutunNo As Byte
Dim syfVeri As Worksheet
Dim syfListe As Worksheet
Dim sonSutunNo_veri As Integer
Const gruplanacak_Sutun_Liste_Harf As String = "j"
Const devamEdenSutunHarf As String = "i"
Set syfVeri = ThisWorkbook.Worksheets("Veri")
Set syfListe = ThisWorkbook.Worksheets("Liste")
With syfVeri
sonSutunNo_veri = .Cells(1, Columns.Count).End(xlToLeft).Column
For m = 1 To sonSutunNo_veri
If LCase(Split(.Cells(1, m).Address, "$")(1)) = LCase(devamEdenSutunHarf) Then
devamedensutunNo = m
Exit For
End If
Next
son = .Range("A" & Rows.Count).End(3).Row + 1
veri = .Range("A2", .Cells(son, sonSutunNo_veri)).Value
ReDim arr(1 To son, 1 To sonSutunNo_veri) 'UBound(veri, 2) demek verini son sütunu
For i = LBound(veri) To UBound(veri)
If LCase(veri(i, devamedensutunNo)) = "devam eden" Then
say = say + 1
For k = 1 To sonSutunNo_veri
arr(say, k) = veri(i, k)
Next
End If
Next
End With
With syfListe
With .Range(.Cells(2, 1), .Cells(Rows.Count, .Columns.Count))
.Borders.LineStyle = xlNone
.ClearContents
End With
End With
If say > 0 Then
With syfListe.Range("C2").Resize(say, sonSutunNo_veri)
.Value = arr
.Sort syfListe.Cells(2, gruplanacak_Sutun_Liste_Harf), xlAscending, , , , , , xlNo
.Borders.LineStyle = 1
End With
End If
MsgBox "Bitti"
On Error Resume Next
Erase veri: Erase arr
Set syfVeri = Nothing
Set syfListe = Nothing
End Sub
