DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
fedeal kardeş gerçekten çok teşekkür ederim
beni çok büyük bir sıkıntıdan kurtarmış bulunuyorsun
Function sirala(Liste As Variant) As Variant
Dim i As Long, k As Byte, j As Long, x As Variant
For i = LBound(Liste) To UBound(Liste) - 1
For j = i + 1 To UBound(Liste)
If Liste(i, 2) > Liste(j, 2) Then
For k = 1 To 2
x = Liste(j, k)
Liste(j, k) = Liste(i, k)
Liste(i, k) = x
Next k
End If
Next j
Next i
sirala = Liste
End Function
Function diziyeal(sut As Integer)
Dim a As Long, i As Long
ReDim myarr(0 To 1, 0 To 1)
For i = 3 To 10
If Cells(i, sut).Value <> "" Then
a = a + 1
ReDim Preserve myarr(0 To 1, 0 To a)
myarr(0, a) = Cells(i, "A").Value
myarr(1, a) = Cells(i, sut).Value
End If
Next i
diziyeal = Application.Transpose(myarr)
Erase myarr
End Function
Sub listele()
Dim a As Long, i As Long
Application.ScreenUpdating = False
Range("A14:F65536").ClearContents
'A-B sütunu B sütunu dolu hücreler sıralanıoyr
Liste = diziyeal(2)
Range("A14").Resize(UBound(Liste), 2) = sirala(Liste)
'A-C sütunları dolu hücreler sıaralanıyor
Erase Liste
Liste = diziyeal(3)
Range("C14").Resize(UBound(Liste), 2) = sirala(Liste)
Erase Liste
Liste = diziyeal(4)
Range("E14").Resize(UBound(Liste), 2) = sirala(Liste)
Erase Liste
End Sub