- Katılım
- 9 Ocak 2014
- Mesajlar
- 55
- Excel Vers. ve Dili
- Office 365 64bit
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Eğer dediğim gibi bir tutarsızlık var ise; yanlış bir çalışma yapmamak adına, sizden doğru bilgileri içeren yeni bir dosya beklemem daha doğru olacaktır.
[FONT="Trebuchet MS"]Sub Emre()
Dim a As Worksheet, i As Worksheet, s%, r%, x%
Application.ScreenUpdating = False
Set a = Worksheets("asıl tablo")
Set i = Worksheets("istenen"): x = 2
For s = 3 To a.Range("A65536").End(3).Row
For r = 2 To a.Cells(1, Columns.Count).End(1).Column Step 3
If a.Cells(s, r) > 0 Then
i.Cells(x, 1) = a.Cells(1, r)
i.Cells(x, 2) = a.Cells(s, 1)
i.Cells(x, 3) = a.Cells(s, r)
x = x + 1
End If
Next r
Next s
i.Range("A2:C" & i.Range("C65536").End(3).Row).Sort i.Range("A2")
Application.ScreenUpdating = True
x = Empty: t = Empty: s = Empty: Set i = Nothing: Set a = Nothing
End Sub[/FONT]
Estağfurullah.
For r = 2
Buradaki 2 rakamını 3 yapmanız yeterli olur.
Rica ederim, size de hayırlı geceler.İlginiz için teşekkürler. Sorunum sayenizde çözülmüştür.