Soru 9
9. sorumuzla devam edelim.
Aşağıdaki gibi bir tablomuz var. Bu tabloda bazı illerin, arasındaki mesafeler yer alıyor.
Sol tarafta yer alan tabloyu, sağ taraftaki formata getirmek istiyorum. Sarı renkli hücreleri, özellikle makro ile döngü oluşturarak yapmak istiyorum.
Dosyayı buradan indirebilir, cevaplarınızı yorum olarak yazabilirsiniz.
CEVAP
Sub Soru9() For i = 2 To 5 For y = 7 To 10 Cells(i, y) = WorksheetFunction.SumIfs(Range("C:C"), _ Range("A:A"), Cells(i, 6), Range("B:B"), Cells(1, y)) Next y Next i End Sub
Merhaba hocam , mesafeleri dizi elemanlarına atayıp sonra da her dizi elemanını örneğin cells(i,7)=dizi[0]
gibi atamayla döngü içerisinde hücrelere yazdırıcaz.
Benim için demesi çok kolay yapması biraz zor :)))
Hocam Merhabalar,
Sub Düğme1_Tıkla()
Z = 2
For i = 3 To 18
For q = 7 To 10
Cells(Z, q) = Cells(i, 3)
i = i + 1
Next q
i = i – 1
Z = Z + 1
Next i
End Sub
Pivot ile yaptım. Güvenlik sebebiyle Makro çalışmıyor.
Merhaba;
Pivot ile nasıl çözdünüz acaba? Çözümü paylaşabilir misiniz?
Sub odev9()
For i = 3 To 18
If Cells(i, 1) = Cells(2, 6) And Cells(i, 2) = Cells(1, 7) Then
Cells(2, 7) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(3, 6) And Cells(i, 2) = Cells(1, 7) Then
Cells(3, 7) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(4, 6) And Cells(i, 2) = Cells(1, 7) Then
Cells(4, 7) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(5, 6) And Cells(i, 2) = Cells(1, 7) Then
Cells(5, 7) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(2, 6) And Cells(i, 2) = Cells(1, 8) Then
Cells(2, 8) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(3, 6) And Cells(i, 2) = Cells(1, 8) Then
Cells(3, 8) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(4, 6) And Cells(i, 2) = Cells(1, 8) Then
Cells(4, 8) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(5, 6) And Cells(i, 2) = Cells(1, 8) Then
Cells(5, 8) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(2, 6) And Cells(i, 2) = Cells(1, 9) Then
Cells(2, 9) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(3, 6) And Cells(i, 2) = Cells(1, 9) Then
Cells(3, 9) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(4, 6) And Cells(i, 2) = Cells(1, 9) Then
Cells(4, 9) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(5, 6) And Cells(i, 2) = Cells(1, 9) Then
Cells(5, 9) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(2, 6) And Cells(i, 2) = Cells(1, 10) Then
Cells(2, 10) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(3, 6) And Cells(i, 2) = Cells(1, 10) Then
Cells(3, 10) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(4, 6) And Cells(i, 2) = Cells(1, 10) Then
Cells(4, 10) = Cells(i, 3)
ElseIf Cells(i, 1) = Cells(5, 6) And Cells(i, 2) = Cells(1, 10) Then
Cells(5, 10) = Cells(i, 3)
End If
Next i
End Sub
Merhabalar;
Tüm tabloyu oluşturmak için kullanılabilecek kod;
Option Explicit
Sub Tablo_Olustur()
Dim sonSutun&, sonF&, sonA&, t&, x&, y&, z&
Application.ScreenUpdating = False
‘————————————————
‘F1 den itibaren dolu olan hücrelerin içeriğini temizleme işlemi
sonSutun = Cells(1, Columns.Count).End(xlToLeft).Column
sonF = Cells(Rows.Count, “F”).End(xlUp).Row
sonA = Cells(Rows.Count, “A”).End(xlUp).Row
Range(Cells(1, “F”), Cells(sonF, sonSutun)).Clear
‘————————————————
‘Şehir İsimlerini Sıralama İşlemi
Range(“F1”) = “İL ADI”
For x = 3 To sonA
sonF = Cells(Rows.Count, “F”).End(xlUp).Row + 1
sonSutun = Cells(1, Columns.Count).End(xlToLeft).Column + 1
If Cells(x, “A”) Cells(x – 1, “A”) Then
Cells(sonF, “F”) = Cells(x, “A”)
End If
If WorksheetFunction.CountIf(Range(Cells(3, 2), Cells(x, “B”)), Cells(x, “B”)) = 1 Then
Cells(1, sonSutun) = Cells(x, “B”)
Cells(1, sonSutun).Orientation = 90
End If
Next x
‘————————————————
‘Tabloyu Doldurma İşlemi
For y = 3 To sonA
For t = 2 To sonF
For z = 7 To sonSutun
If Cells(t, “F”) = Cells(y, “A”) And Cells(1, z) = Cells(y, “B”) Then
Cells(t, z) = Cells(y, “C”)
With Cells(t, z)
.NumberFormat = “#,##0”
.Borders(xlEdgeLeft).LineStyle = xlContinuous
.Borders(xlEdgeTop).LineStyle = xlContinuous
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeRight).LineStyle = xlContinuous
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Interior.ColorIndex = 6
End With
If Cells(t, z) = 0 Or Cells(t, z) = Empty Then Cells(t, z) = “-”
End If
Next z
Next t
Next y
Range(“F:F”).EntireColumn.AutoFit
Rows(“1:1”).EntireRow.AutoFit
sonSutun = Empty: sonA = Empty: sonF = Empty
t = Empty: x = Empty: y = Empty: z = Empty
Application.ScreenUpdating = True
End Sub
Sub kilometre()
sonsatir = Cells(Rows.Count, “a”).End(xlUp).Row
Range(“f1”) = “IL ADI”
For i = 3 To sonsatir
Cells(i – 1, 6) = Cells(i, 1)
Next i
Range(“f2”, “f” & sonsatir).RemoveDuplicates (1)
sonsatir2 = Cells(Rows.Count, “f”).End(xlUp).Row
For y = 2 To sonsatir2
Cells(1, 6 + y – 1) = Cells(y, 6)
Next y
For Z = 2 To sonsatir2
For t = sonsatir2 + 2 To sonsatir2 * 2
Cells(Z, t) = Application.WorksheetFunction.SumIfs(Range(“c2”, “c” & sonsatir), Range(“a2”, “a” & sonsatir), _
Cells(Z, 6), Range(“b2”, “b” & sonsatir), Cells(1, t))
Next t
Next Z
End Sub
Sub alper()
Dim satir As Long
Dim sutun As Long
Dim x As Long
Dim r As Long
Dim c As Long
Dim dizim(18, 2) As String
satir = 2
sutun = 7
Range(“F:K”).ClearContents
Cells(1, “F”) = “İL ADI”
For r = 3 To 18
dizim(r – 3, 1) = Cells(r, 1) & Cells(r, 2)
If Cells(r, 3) = “” Then
dizim(r – 3, 2) = 0
Else
dizim(r – 3, 2) = Cells(r, 3)
End If
If Cells(satir – 1, “F”) Cells(r, 1) Then
Cells(satir, “F”) = Cells(r, 1)
Cells(1, sutun) = Cells(r, 1)
satir = satir + 1
sutun = sutun + 1
End If
Next r
For r = 2 To 5
For c = 7 To 10
For x = LBound(dizim) To UBound(dizim)
If dizim(x, 1) = Cells(r, 6) & Cells(1, c) Then
Cells(r, c) = dizim(x, 2)
End If
Next x
Next c
Next r
End Sub