Formülleri koda çevirmek

[vurkan]

Arkadaşlar Merhaba bir önceki dosyamda kullanmak üzere sayfadaki formülleri kod ile nasıl ifade ederiz acaba. "ANA SAYFA" isimli sayfamızda 5000 satırlık bir tablomuz var. 3. satırdan itibaren;

F3 ten itibaren F5003 e kadar =EĞER(E3="";"";İNDİS(SABİTLER!$F$2:$F$1000;KAÇINCI(E3;SABİTLER!$E$2:$E$1000;0))) şeklinde formülümüz var.
J3 ten itibaren J5003 e kadar =EĞER(G3="";"";(F3*G3)+(F3*G3)*SABİTLER!$G$2) şeklinde formülümüz var.
K3 ten itibaren K5003 e kadar da =EĞER(H3+I3=0;J3;J3-(H3+I3)) şeklinde formülümüz var.
H1 I1 J1 ve K1 hücrelerinde ise örneğin =ALTTOPLAM(9;K3:K5000) şeklinde alttoplam formülleri var. Bu formüller 5003 stıra kadar köşeden sürüklenip çoğaltıldı.

Benim yapmak istediğim bu formüllerin yerine bu işlemi yapacak bir kod yazmak. Böylece ÖDENENLER sayfasına aktarılan satırların yerine formüllü satır ekleme ihtiyacı kalmaması. İlgilenecek arkadaşlara Şimdiden teşekkür ediyorum.

 

[çıtır]

Örnek dosya olmadan anlayabildiğim kadar.Deneyiniz.

Sub kodlar()
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim i As Integer
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("SABİTLER")
son1 = s1.Cells(65536, "E").End(3).Row
son2 = s2.Cells(65536, "E").End(3).Row
For i = 3 To son1
Bul = WorksheetFunction.CountIf(s2.Range("E2:E1000"), s1.Range("E" & i))
If Bul > 0 Then
aranan = WorksheetFunction.Match(s1.Range("E" & i), s2.Range("E2:E1000"), 0)
Range("F" & i) = WorksheetFunction.Index(s2.Range("F2:F1000"), aranan)
Range("j" & i) = s1.Range("F" & i) * (s1.Range("G" & i)) + s1.Range("F" & i) * (s1.Range("G" & i)) * s2.Range("G2")
If s1.Range("H" & i) + s1.Range("I" & i) = 0 Then
Range("K" & i) = s1.Range("J" & i)
Else
s1.Range("K" & i) = s1.Range("J" & i) - (s1.Range("H" & i) + s1.Range("I" & i))
End If
s1.Range("H1") = WorksheetFunction.Subtotal(9, Range("H3:H5000"))
s1.Range("I1") = WorksheetFunction.Subtotal(9, Range("I3:I5000"))
s1.Range("J1") = WorksheetFunction.Subtotal(9, Range("J3:J5000"))
s1.Range("K1") = WorksheetFunction.Subtotal(9, Range("K3:K5000"))
End If
Next i
End Sub

 

[vurkan]

Sayın Çıtır. İlginize teşekkür ederim. Kodlar gayet güzel çalıştı. Yalnız Bu kodları bir düğme ile değil de otomatik çalıştırmalıyım.

Bir de size zahmet olmaz ise ekli dosyadaki "ANA SAYFA"da C D ve E sütunlarında filtre uygulanıp L sütununda ÖDENDİ (çift tıklama) işaretlenenleri ÖDENENLER sayfasına değer olarak (tüm satırı A:K arası) aktarması. (veya dosyanın boyutlarının artmasını önlemek için Ödenenler isimli bir dosya açıp oraya kopyalanması için nasıl bir kod yazmalı. Teşekkürler.


http://s7.dosya.tc/server8/53djct/NAKLIYE_PROGRAMI_1.rar.html

 

[çıtır]

Ana Sayfa sekmesinde fare sağ tuş yapınız.Kodları görüntüle seçiniz.Çıkan alana kodu kopyalayınız.

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [E3:E5000,G3:G5000,H3:H5000,I3:I5000,L3:L5000]) Is Nothing Then Exit Sub
Dim s1 As Worksheet
Dim s2 As Worksheet
Dim s3 As Worksheet
Dim i As Integer
Set s1 = Sheets("ANA SAYFA")
Set s2 = Sheets("SABİTLER")
Set s3 = Sheets("ÖDENENLER")
son1 = s1.Cells(65536, "E").End(3).Row
son2 = s2.Cells(65536, "E").End(3).Row
son3 = s3.Cells(65536, "E").End(3).Row
For i = 3 To son1
Bul = WorksheetFunction.CountIf(s2.Range("E2:E1000"), s1.Range("E" & i))
If Bul > 0 Then
aranan = WorksheetFunction.Match(s1.Range("E" & i), s2.Range("E2:E1000"), 0)
Range("F" & i) = WorksheetFunction.Index(s2.Range("F2:F1000"), aranan)
Range("j" & i) = s1.Range("F" & i) * (s1.Range("G" & i)) + s1.Range("F" & i) * (s1.Range("G" & i)) * s2.Range("G2")
If s1.Range("H" & i) + s1.Range("I" & i) = 0 Then
Range("K" & i) = s1.Range("J" & i)
Else
s1.Range("K" & i) = s1.Range("J" & i) - (s1.Range("H" & i) + s1.Range("I" & i))
End If
s1.Range("H1") = WorksheetFunction.Subtotal(9, Range("H3:H5000"))
s1.Range("I1") = WorksheetFunction.Subtotal(9, Range("I3:I5000"))
s1.Range("J1") = WorksheetFunction.Subtotal(9, Range("J3:J5000"))
s1.Range("K1") = WorksheetFunction.Subtotal(9, Range("K3:K5000"))
End If
Next i
s3.Range("B3:L" & s3.Cells(65336, "L").End(3).Row).ClearContents
sat = 3
For y = 2 To 12
For i = 3 To son1
If Range("L" & i) <> "" Then
s3.Cells(sat, y) = Cells(i, y)
s3.Cells(sat, 12).Font.Name = "Wingdings"
sat = sat + 1
End If
Next i
sat = 3
Next y
End Sub

 

[vurkan]

Sayın Çıtır kodları dediğiniz gibi yaptım ama:

Private Sub Worksheet_Change(ByVal Target As Range)
Kompile Error hatası verdi.

Daha önce yazdığım kodları silince çalıştı ama L sütununa çift tıklama özelliği, filtreleri kaldırma özelliği çalışmıyor. Ayrıca Alttoplam hücreleri de L sütununa Y yazmadan aktif olmuyor. ÖDENENLER sayfasına aktarılanlar da aynı sayfada kalmaya devam ediyor. Oysa ANA SAYFA dan silinerek aktarılmalı.

Eğer sizleri yormayacaksam;

B sütunu harf veya rakam içeriyorsa A sütununa BUGÜN ün tarihi,
Bir Düğme yardımıyla tüm filtreleri kaldırma;
Filtre yapılınca alttoplamlar hemen çalışmalı, (ki toplam ödeme ona göre yapılacak)
L sütunundaki çift tıklama yapılınca satır silinerek ÖDENENLER e aktarılmalı, Boş satırlar silinmeli.
(Sizleri uğraştırıyorum Hakkınızı helal edin) Teşekkürler.

 

[vurkan]

Sayın Çıtır ve Arkadaşlar tekrar merhaba.
5. mesajımdaki bir kısım sorunları hallettim. Ancak iki konuda yardıma ihtiyacım devam ediyor.

1- Filtre yapılınca alttoplamlar hemen çalışmalı, (ki toplam ödeme ona göre yapılacak)
2- L sütunundaki çift tıklama yapılınca satır kes yapıştır gibi ÖDENENLER e aktarılmalı, Aradaki boşalan satırlar silinmeli.


http://s3.dosya.tc/server16/fecr7z/NAKLIYE_PROGRAMI_2.rar.html

 

[çıtır]

Çözümlenmiş dosyanız.
http://dosya.la/download/e5440048d726e6d2c78f1d80ced9b762.html

 

[vurkan]

Sayın Çıtır. Ellerin dert görmesin. Tam düşündüğüm gibi olmuş. Çok teşekkürler.
Merhaba şimdi farkettim. L sütununun 2. başlık satırlarını da çift tıklamayla aktarıyor. Bunu nasıl önleyebilirim acaba.
Nasıl olur bilmiyorum ama bu dosyada son bir hayalim kaldı. ANA SAYFA 3. satırı veri giriş satırı yapmak. G sütununda ton girip enter yapınca 3. satır bir alt satıra kayacak. Her giriş 3. satırdan olacak.

 

[çıtır]

Bu kodu aşağıdaki ile değiştirin

If süt = 12 And sat >= 2 And sat <= 5000 Then

If süt = 12 And sat > 2 And sat <= 5000 Then

MsgBox önce ileve ediniz.

If t > 2 Then

MsgBox "Veri ödenenlere aktarıldı", vbInformation, "BİLGİ"

End If

 

[vurkan]

Sayın Çıtır. Seni çok yordum. Çok teşekkür ediyorum.

 

[çıtır]

Sayın Çıtır. Seni çok yordum. Çok teşekkür ediyorum.

Rica ederim.Dönüş yaptığınız için teşekkür ederim.