Soru Formül içeriğini makroyla değiştirmek

[kayitdefteri]

Merhabalar sağlıklı günler,

Sorum şöyle ki, D ve E hücrelerinde 2. satırdan 1001. satıra kadar bulunan konum (x ve y) verilerini "=YUVARLA((KAREKÖK(($D$2-D2)^2+($E$2-E2)^2));0)" bu formülle hesaplayıp mesafe matrisi oluşturmam gerekiyor. Bahsettiğim matris köşegenleri 0 (sıfır) olan 1000x1000 bir matris olacak.

( i, i-1 ) numaraları sütünlara yukarıda verdiğim formülü yapıştırıp alt kısımları otomatik dolduracak bir makro yazmaya çalışıyorum. Fakat formül içerisindeki hücreleri makroda nasıl sabitlerim ve bir sonraki adımda nasıl numaralarını artırabilirim bilmiyorum.

Örnek olarak;

=YUVARLA((KAREKÖK(($D$2-D2)^2+($E$2-E2)^2));0) J2 hücresine yapıştırılıp 1001. satıra kadar otomatik doldurma yapılacak.
=YUVARLA((KAREKÖK(($D$3-D3)^2+($E$3-E3)^2));0) K3 hücresine yapıştırılıp 1001. satıra kadar otomatik doldurma yapılacak.
=YUVARLA((KAREKÖK(($D$4-D4)^2+($E$4-E4)^2));0) L4 hücresine yapıştırılıp 1001. satıra kadar otomatik doldurma yapılacak.

Şimdiden teşekkürler...

 

[hmtstc]

dosya paylaşır mısınız

 

[çıtır]

Sayın hmtstc'nin müsadesi ile aşağıdaki şekilde bir deneyiniz.Başa sayfa tanımıda yapabilirsiniz.

Sub formülyaz()
Range("J2:J1001").FormulaLocal = "=YUVARLA((KAREKÖK(($D$2-D2)^2+($E$2-E2)^2));0)"
Range("K3:K1001").FormulaLocal = "=YUVARLA((KAREKÖK(($D$3-D3)^2+($E$3-E3)^2));0)"
Range("L4:L1001").FormulaLocal = "=YUVARLA((KAREKÖK(($D$4-D4)^2+($E$4-E4)^2));0)"
End Su

 

[kayitdefteri]

dosya paylaşır mısınız

ilgili dosya

Sayın hmtstc'nin müsadesi ile aşağıdaki şekilde bir deneyiniz.Başa sayfa tanımıda yapabilirsiniz.

Sub formülyaz()
Range("J2:J1001").FormulaLocal = "=YUVARLA((KAREKÖK(($D$2-D2)^2+($E$2-E2)^2));0)"
Range("K3:K1001").FormulaLocal = "=YUVARLA((KAREKÖK(($D$3-D3)^2+($E$3-E3)^2));0)"
Range("L4:L1001").FormulaLocal = "=YUVARLA((KAREKÖK(($D$4-D4)^2+($E$4-E4)^2));0)"
End Su

hocam tek tek 1000 tane hücreye formülü yazmak istemiyorum. istediğim şey bir şekilde formülü for döngüsüne bağlayıp, (i, i-1) hücrelerine yazdırmak aynı zamanda formülün içeriğindeki referans hücreler değişmeli.

 

[çıtır]

Makro 1000 satırın ilgili sütunlarına yani 3 sütun 1000 satırına yazar.Siz daha fazla sütuna mı yazmak istiyırsunuz? anlamadım.Makroyu denediniz mi?

 

[kayitdefteri]

Makro 1000 satırın ilgili sütunlarına yani 3 sütun 1000 satırına yazar.Siz daha fazla sütuna mı yazmak istiyırsunuz? anlamadım.Makroyu denediniz mi?

şöyle örnek vereyim. 4,3 hücresinden itibaren 1001,1000 hücresine kadar her adımda sağ alt çaprazına yazmasını istiyorum. yani formülün yazılacağı hücreler 4,3 / 5,4 / 6,5 / 7,6 ........ (i, i-1) 1001,1000 şeklinde. örnek dosya paylaştım orada görebilirsiniz.

=YUVARLA((KAREKÖK(($D$2-D2)^2+($E$2-E2)^2));0) J2 hücresine yapıştırılıp 1001. satıra kadar otomatik doldurma yapılacak.
=YUVARLA((KAREKÖK(($D$3-D3)^2+($E$3-E3)^2));0) K3 hücresine yapıştırılıp 1001. satıra kadar otomatik doldurma yapılacak.
=YUVARLA((KAREKÖK(($D$4-D4)^2+($E$4-E4)^2));0) L4 hücresine yapıştırılıp 1001. satıra kadar otomatik doldurma yapılacak.
. . .
. . .
. . .
=YUVARLA((KAREKÖK(($D$1001-D1001)^2+($E$1001-E1001)^2));0) ALU1001 hücresine yapıştırılacak.

 

[çıtır]

Döngü ile aşağıdaki şekilde olabilir.Ben 100 sütun için denedim bayağı süre geçti,artık 1000 sütun için ne kadar süre geçer bilemem.

Sub Formülyaz()
a = 10
Do
For sat = 2 To 1001
Sheets("Sayfa1").Cells(sat + ss, a).FormulaLocal = "=YUVARLA((KAREKÖK(($D" & 2 + ss & "-" & "D" & sat + a - 10 & ")^2+($E" & 2 + ss & "-" & "E" & sat + a - 10 & ")^2));0)"
Next sat
a = a + 1
ss = ss + 1
Loop While a < 1001

End Sub

Yeni düzenleme

 

[YUSUF44]

Aşağıdaki gibi mi istiyorsunuz?:

Sub matrisle()
son = Cells(Rows.Count, "D").End(3).Row
For i = 2 To son
    Cells(i, "J").FormulaR1C1 = "=ROUND((SQRT((R2C4-RC[-6])^2+(R2C5-RC[-5])^2)),0)"
    If i >= 5 Then
        Cells(i, "K").FormulaR1C1 = "=ROUND((SQRT((R3C4-RC[-7])^2+(R3C5-RC[-6])^2)),0)"
        Cells(i, "L").FormulaR1C1 = "=ROUND((SQRT((R4C4-RC[-8])^2+(R4C5-RC[-7])^2)),0)"
        Cells(i, "M").FormulaR1C1 = "=ROUND((SQRT((R5C4-RC[-9])^2+(R5C5-RC[-8])^2)),0)"
    ElseIf i >= 4 Then
        Cells(i, "K").FormulaR1C1 = "=ROUND((SQRT((R3C4-RC[-7])^2+(R3C5-RC[-6])^2)),0)"
        Cells(i, "L").FormulaR1C1 = "=ROUND((SQRT((R4C4-RC[-8])^2+(R4C5-RC[-7])^2)),0)"
    ElseIf i >= 3 Then
        Cells(i, "K").FormulaR1C1 = "=ROUND((SQRT((R3C4-RC[-7])^2+(R3C5-RC[-6])^2)),0)"
    End If
Next
End Sub

 

[kayitdefteri]

Döngü ile aşağıdaki şekilde olabilir.Ben 100 sütun için denedim bayağı süre geçti,artık 1000 sütun için ne kadar süre geçer bilemem.

Sub Formülyaz()
a = 10
Do
For sat = 2 To 1001
Sheets("Sayfa1").Cells(sat + ss, a).FormulaLocal = "=YUVARLA((KAREKÖK(($D" & 2 + ss & "-" & "D" & sat + a - 10 & ")^2+($E" & 2 + ss & "-" & "E" & sat + a - 10 & ")^2));0)"
Next sat
a = a + 1
ss = ss + 1
Loop While a < 1001

End Sub

Yeni düzenleme

Çok teşekkürler, tam istediğim gibi çalıştı. Biraz uzun sürecek gibi evet ama benim için önemli olan bu veriler. O yüzden ne kadar sürdüğü önemli değil.

 

[çıtır]

Çok teşekkürler, tam istediğim gibi çalıştı. Biraz uzun sürecek gibi evet ama benim için önemli olan bu veriler. O yüzden ne kadar sürdüğü önemli değil.

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

 

[çıtır]

Aşağıdaki yazımda işlemi 1-1,5 dakikaya düşürüyor.

Sub Formülyaz()
Dim s1 As Worksheet
Dim sat As Long: Dim a As Long
Dim ss As Long
Set s1 = Sheets("veri")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Zaman = Timer
a = 10
ss = 0
Do
For sat = 2 To 1001 - ss
s1.Cells(sat + ss, a).FormulaLocal = "=YUVARLA((KAREKÖK(($D" & 2 + ss & "-" & "D" & sat + a - 10 & ")^2+($E" & 2 + ss & "-" & "E" & sat + a - 10 & ")^2));0)"
Next sat
a = a + 1
ss = ss + 1
Loop While a < 1001

Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
 MsgBox "İşleminiz tamamlanmıştır." & Chr(10) & Chr(10) & _
           "İşlem süresi ; " & Format(Timer - Zaman, "0.00") & " Saniye", vbInformation

sat = Empty: a = Empty: ss = Empty: Set s1 = Nothing
    
End Sub

 

[leguminosea]

Alternatif olsun.

Hata indir

Hata

www.dosyaupload.com