Makro Mantığı Kurma - Yardım

[entalpi]

Merhaba, ekteki dosya, firmalara belirli saatlerde verilen randebuları kaydetmeyi amaçlamaktadır. Dosya açıldığında iki firmayı göreceksiniz. Fakat ben 1.firmanın üstüne gelip "Randevu Sil" butonuna basıp firmayı sildiğimde, artık 2.firmadaki verinin 2.firmadaki verinin yerine geçmesini istiyorum. Ama bir türlü mantığı kuramadım. Firma sayısının 7 ile sınırlı olması da gerekiyor. O yüzden yardımınıza çok ihtiyacım var. En azından bir yol gösteren olursa sevinirim, teşekkürler

 

[Ferhat Pazarçevirdi]

Merhabalar

Userform2'deki CommandButton2 (Evet Butonu) kodlarını aşağıdaki gibi revize ediniz.

Private Sub CommandButton2_Click()
Dim arrVeri()
Dim rg As Range
Dim sut As Integer
Dim j As Integer
Dim i As Integer
Dim x As Integer
ActiveSheet.Unprotect
Set rg = Range("H4:AB27")
If Not Intersect(ActiveCell, rg) Is Nothing Then
   sut = (ActiveCell.Column - 8) Mod 3
   With ActiveCell
       .Offset(0, 0 - sut) = Empty
       .Offset(0, 1 - sut) = Empty
       .Offset(0, 2 - sut) = Empty
   End With
End If
For j = 8 To 26 Step 3
    If Cells(ActiveCell.Row, j) <> Empty Then
       y = y + 1
       ReDim Preserve arrVeri(1 To 3, 1 To y)
       arrVeri(1, y) = Cells(ActiveCell.Row, j)
       arrVeri(2, y) = Cells(ActiveCell.Row, j + 1)
       arrVeri(3, y) = Cells(ActiveCell.Row, j + 2)
    End If
Next j
Range("H" & ActiveCell.Row & ":AB" & ActiveCell.Row).ClearContents
x = 8
If y = Empty Then: Unload Me: Exit Sub
For i = 1 To UBound(arrVeri, 2)
    Cells(ActiveCell.Row, x) = arrVeri(1, i)
    Cells(ActiveCell.Row, x + 1) = arrVeri(2, i)
    Cells(ActiveCell.Row, x + 2).Formula = "=IF(" & Cells(ActiveCell.Row, x).Address & "=" & Chr(34) & Chr(34) & "," _
                                                                                           & Chr(34) & Chr(34) & "," _
                                                                                           & "VLOOKUP(" & Cells(ActiveCell.Row, x).Address & "," & Range("H100:I606").Address & ",2,FALSE))"
    x = x + 3
Next i
Set rg = Nothing
ActiveSheet.Protect
Unload Me
End Sub

Ekteki dosyayı inceleyiniz.

 

[entalpi]

Merhaba, Ferhat Bey, dediğiniz gibi yaptığımda Elleç sütunundaki formuller siliniyor, bu konuda ne yapabilirim? teşekkürler

 

[Ferhat Pazarçevirdi]

2 Nolu mesajdaki dosyayı revize ettim. Tekrar indiriniz.

 

[entalpi]

Tekrar merhaba Ferhat Bey, çözümünüz için teşekkürler fakat bu sefer başka bir sorun çıktı. Randevu sildiğimizde, vlookuplı olan ve formül içeren hücredeki formül siliniyor ve yeni randevu yaratıldığında, vlookup çekilmediği için firma isimlerinde E kolonu çıkmıyor. Randevu yarat'taki kaydete bastığımda vlookup çekmesini sağlamam gerekiyor sanırım. Nasıl yaparım biliyor musunuz, sizden çok yardım istedim ama kusura bakmayın. Bunu da çözerseniz herşey tamam olacak, çok teşekkürler