modoste
Altın Üye
- Katılım
- 31 Mayıs 2008
- Mesajlar
- 3,714
- Excel Vers. ve Dili
- Microsoft OFFİCE Ev ve İş 2019 TR
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Sub TabloOluştur()
Dim Alan1 As Range
Dim Alan2 As Range
On Error Resume Next
Application.DisplayAlerts = False
Set Alan1 = Application.InputBox("Hücre seçin", Type:=8)
Set Alan2 = Application.InputBox("Hücre seçin", Type:=8)
If Alan1 Is Nothing Or Alan2 Is Nothing Then
MsgBox "Alanları Tekrar Seçin"
GoTo Son
End If
Range(Alan2.Address) = "Tarih"
Range(Alan2.Address).Offset(0, 1) = "Malzeme"
Range(Alan2.Address).Offset(0, 2) = "Miktar"
For i = Alan1.Row + 1 To Alan1.Rows.Count + Alan1.Row - 1
For k = Alan1.Column + 1 To Alan1.Columns.Count + Alan1.Column - 1
If Cells(i, k) > 0 Then
x = x + 1
Range(Alan2.Address).Offset(x, 0) = Cells(i, Alan1.Column)
Range(Alan2.Address).Offset(x, 1) = Cells(Alan1.Row, k)
Range(Alan2.Address).Offset(x, 2) = Cells(i, k)
End If
Next k
Next i
Son:
Application.DisplayAlerts = True
End Sub