İşlerin periyodik olarak tabloya yerleştirilmesi

[Imrahil]

Merhaba arkadaşlar,

Yardımcı olmaya çalışanlara şimdiden teşekkürler. Sorum şu şekilde :

Hangi sıklıkla yapılacağını bildiğimiz işlerimiz var. Bu işler ve sıklıkları gönderdiğim örnek tabloda var. Tabloda da görebileceğiniz gibi İş1 13 günde bir, İş2 2 günde, iş3 5 günde bir yapılıyor.... Ama bu veriler bize az önce yazdığım gibi sayılarla verilmemiş de bir tabloya yerleştirilmiş "x"lerle gösterilmiş. Sıklıkları x'in bulunduğu sütuna bakarak anlayabiliyoruz.

Bizden istenen her satır için x'in bulunduğu yeri bulacak, sonra da yapılma sıklığına göre tablonun geri kalanına periodik olarak x'leri yerleştirecek bir macro.

Örnek tabloya bakarak sorumu çok daha rahat anlayabilirsiniz.

Ben tablodaki iş1 ve ilk günün kesiştiği kısmı (1,1)' e taşıyarak birşeyler yapmaya çalıştım ve şöyle birşey yazdım ama olmadı. Kodun sorununu da söyleyebilirseniz çok memnun olurum.

Sub Perioddd()
Dim i, j, k As Integer
For j = 1 To 7
For i = 1 To 31
If Cells(j, i) = "x" Then
k = i * 2
Do While k <= 31
Cells(j, k) = x
k = k * 2
Loop
End If
Next i
Next j
End Sub


Şunu da söyleyeyim asıl tablo bundan çok daha büyük yoksa sizi yormazdım.

Çok teşekkürler

 

[N.Ziya Hiçdurmaz]

Yanıt

Örneği inceleyiniz.

Sub TEST()
Dim SAT, SAT1, SAT2 As Integer
[c18:ag24].ClearContents
For SAT = 3 To 33 Step [AH5]
For Each SAT1 In Range("C5:AG5")
If SAT1 = "x" Then
SAT1.Copy
Cells(18, SAT - 1).PasteSpecial
[B18] = "iş 1"
End If
Next
Next
'***
For SAT = 3 To 33 Step [AH6]
For Each SAT1 In Range("C6:AG6")
If SAT1 = "x" Then
SAT1.Copy
Cells(19, SAT - 1).PasteSpecial
[B19] = "iş 2"
End If
Next
Next
'***
For SAT = 3 To 33 Step [AH7]
For Each SAT1 In Range("C7:AG7")
If SAT1 = "x" Then
SAT1.Copy
Cells(20, SAT - 1).PasteSpecial
[B20] = "iş 3"
End If
Next
Next
'***
For SAT = 3 To 33 Step [AH8]
For Each SAT1 In Range("C8:AG8")
If SAT1 = "x" Then
SAT1.Copy
Cells(21, SAT - 1).PasteSpecial
[B21] = "iş 4"
End If
Next
Next
'***
For SAT = 3 To 33 Step [AH9]
For Each SAT1 In Range("C9:AG9")
If SAT1 = "x" Then
SAT1.Copy
Cells(22, SAT - 1).PasteSpecial
[B22] = "iş 5"
End If
Next
Next
'***
For SAT = 3 To 33 Step [AH10]
For Each SAT1 In Range("C10:AG10")
If SAT1 = "x" Then
SAT1.Copy
Cells(23, SAT - 1).PasteSpecial
[B23] = "iş 6"
End If
Next
Next
'***
For SAT = 3 To 33 Step [AH11]
For Each SAT1 In Range("C11:AG11")
If SAT1 = "x" Then
SAT1.Copy
Cells(24, SAT - 1).PasteSpecial
[B24] = "iş 7"
End If
Next
Next
Application.CutCopyMode = False
MsgBox "İşlem tamam", vbInformation
End Sub