maliyet hazırlama

[otelci01]

Merhaba, ekte yolladığım dosyada 2 hücredeki bilgileri çift tıklayarak aşağıdaki bir hücreye aktarmak istiyorum. yardımlarınız için şimdiden teşekkür ederim.

 

[nsertoglu]

Bakın olmuş mu?

Önce değiştirilen dosyayı (maliyet_ns.xlsx) indirin ve Aşağıdaki makroyu bu dosyaya ekleyin..
Değiştirilen dosya *xlsx* olarak eklendi, bakın bakalım işinizi görecek veya size başlangıç fikri verecek mi? Kolay gelsin..

Sub sec_Maliyete_ekle()
Sheets("Sayfa1").Select
' Maliyet hesabına yazılacaklar için hazırlık
yR = 3 ' 2nci satırdan başla
yK = 20 ' "T" kolonu
topl = 0
GoSub sec_temizle

Cells(2, "a").Select
bslk = ActiveCell.Value
sonR = Selection.End(xlDown).Row
GoSub sec_bul_ekle

Cells(2, "d").Select
bslk = ActiveCell.Value
sonR = Selection.End(xlDown).Row
GoSub sec_bul_ekle

Cells(2, "G").Select
bslk = ActiveCell.Value
sonR = Selection.End(xlDown).Row
GoSub sec_bul_ekle

Cells(2, "J").Select
bslk = ActiveCell.Value
sonR = Selection.End(xlDown).Row
GoSub sec_bul_ekle

Cells(2, "M").Select
bslk = ActiveCell.Value
sonR = Selection.End(xlDown).Row
GoSub sec_bul_ekle

Cells(2, "P").Select
bslk = ActiveCell.Value
sonR = Selection.End(xlDown).Row
GoSub sec_bul_ekle

' hesap Toplamı
Cells(3, "T").Select
deg_kol = ActiveCell.Column + 2
sonR = Selection.End(xlDown).Row
For r = 3 To sonR
Cells(r, deg_kol).Select
deg = Cells(r, deg_kol).Value
topl = topl + deg
Next r

Cells(sonR + 2, deg_kol).Select
Cells(sonR + 2, deg_kol - 1) = "Toplam :"
Cells(sonR + 2, deg_kol) = topl

End

sec_bul_ekle:
For r = 3 To sonR
If Cells(r, ActiveCell.Column + 2) <> Empty Then
Cells(yR, yK) = bslk
adt = Cells(r, ActiveCell.Column + 2)
Cells(yR, yK + 1) = Cells(r, ActiveCell.Column)
Cells(yR, yK + 2) = Cells(r, ActiveCell.Column + 1) * adt
yR = yR + 1
End If
Next r

Return

sec_temizle:
Cells(yR, yK).Select

For r = 2 To 50 ' maks. 50 kalemlik hesap yazılsa
Cells(r, yK) = Empty
Cells(r, yK + 1) = Empty
Cells(r, yK + 2) = Empty
Cells(r, yK + 3) = Empty

Next r

Return

End Sub

 

[otelci01]

Merhaba, dosyanızı açamadım.