• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

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

K

kayitdefteri

Katılım
14 Nisan 2020
Mesajlar
4
Excel Vers. ve Dili
Office 365 / Türkçe
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...
 
Sayın hmtstc'nin müsadesi ile aşağıdaki şekilde bir deneyiniz.Başa sayfa tanımıda yapabilirsiniz.
Kod: 
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
 
hmtstc' Alıntı:
dosya paylaşır mısınız
Genişletmek için tıkla ...

ilgili dosya

çıtır' Alıntı:
Sayın hmtstc'nin müsadesi ile aşağıdaki şekilde bir deneyiniz.Başa sayfa tanımıda yapabilirsiniz.
Kod: 
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
Genişletmek için tıkla ...

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.
 
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?
 
çıtır' Alıntı:
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?
Genişletmek için tıkla ...

şö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.
 
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.
Kod: 
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
 
Son düzenleme:
Aşağıdaki gibi mi istiyorsunuz?:

PHP: 
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
 
çıtır' Alıntı:
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.
Kod: 
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
Genişletmek için tıkla ...

Ç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.
 
Aşağıdaki yazımda işlemi 1-1,5 dakikaya düşürüyor.
Kod: 
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
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst