DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub AKTAR()
Dim hcr As Range, son As Integer, hcrr As Range, j As Integer, i As Integer, k As Integer
Set hcr = Sayfa1.Range("A1")
son = 4
Application.ScreenUpdating = False
Sayfa1.Range("A4:J40").ClearContents
For j = 2 To 5
For i = 3 To 20
If Sheets(j).Cells(i, 2) = hcr Then
Set hcrr = Sheets(j).Cells(i, 2)
For k = 2 To 10
Cells(son, "A") = son - 3
Cells(son, k) = hcrr.Offset(0, k - 2)
Next k
son = son + 1
End If
Next i
Next j
Set hcr = Nothing
Set hcrr = Nothing
End Sub
Sayın Ayhan Ercan ilginize çok teşekkür ederim. Saygılar