Makronun diğer sayfaya uyarlanması...

[manly]

Ekte gönderdiğim dosyanın HESAPLAT butonuna tıkladığımda hesaplamayı TOPLAM sayfasına aktarıyor. ANASAYFA ya da formül ile bağlantı yapılmıştır. Ben işlemin direkt ANASAYFA ya makro ile yapılmasını istiyorum.

 

[manly]

Yardımlarınızı bekliyorum...

 

[Mustafa MUTLU]

Set t = Sheets("TOPLAM") kodundaki sayfa adnı değiştirin
Set t = Sheets("ANASAYFA") gibi..

 

[manly]

Hocam iki sayfa birbirinden farklı yapıda. Hücreler aynı değil..Nasıl olacak anlamadım.

 

[vardar07]

Deneyiniz.

Sub TOPARLA()
Dim t As Worksheet
Set t = Sheets("ANASAYFA")
Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
t.Range("B3:C44,E3:F44").ClearContents
  a = 3
For sat = 16 To 29
    For sut = 3 To 11
    b = 2
    If sut = 5 Or sut = 9 Then sut = sut + 2
        For s = 1 To Sheets.Count
            If Sheets(s).Name <> "ANASAYFA" And Sheets(s).Name <> "TOPLAM" Then
         If Sheets(s).Cells(sat, sut) <> "" Then
        t.Cells(a, b) = t.Cells(a, b) + Sheets(s).Cells(sat, sut)
        t.Cells(a, b + 1) = t.Cells(a, b + 1) + Sheets(s).Cells(sat, sut + 1)
            a = a + 1
            End If
            End If
        Next
        b = b + 1
        Next
        b = 2
        Next
        a = 3
 For sat = 36 To 49
    For sut = 3 To 12
    b = 5
    If sut = 5 Or sut = 9 Then sut = sut + 2
        For s = 1 To Sheets.Count
            If Sheets(s).Name <> "ANASAYFA" And Sheets(s).Name <> "TOPLAM" Then
         If Sheets(s).Cells(sat, sut + 1) <> "" Then
       t.Cells(a, b) = t.Cells(a, b) + Sheets(s).Cells(sat, sut)
        t.Cells(a, b + 1) = t.Cells(a, b + 1) + Sheets(s).Cells(sat, sut + 1)
            a = a + 1
            End If
            End If
        Next
        b = b + 1
        Next
        b = 2
        Next
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı..."
End Sub

 

[manly]

Hocam denedim bir sorun var sanırım. Hatalı dosyayı gönderdim.

 

[vardar07]

Eklediğiniz dosya hatalı kontrol ediniz.

 

[manly]

Eklediğim dosya sizin makronuzdan sonra böyle oldu. .

 

[vardar07]

Bende hiç bir sorun yaratmıyor.
Sizdeki kodu silmeden eklediyseniz olabileceğini sanmıyorum ama olabilir de.

 

[manly]

Diğer sayfalara değer atayınca olay değişiyor hocam...Bunun gibi bir sürü sayfa ilave olacak...

 

[manly]

Daha sade bir dosya gönderdim. TOPLAM sayfasındaki sarı renkteki hücrelerdeki değerler ANASAYFA daki sarı olan yerlerine makro ile aktarılsın.

 

[vardar07]

Başka bir module ekleyin yada sizdekileri kaldırıp ekleyerek deneyiniz.

Sub TOPARLA()
Dim t As Worksheet, m As Worksheet
Set t = Sheets("ANASAYFA")
Set m = Sheets("TOPLAM")
Application.Calculation = xlCalculationManual: Application.ScreenUpdating = False
t.Range("B3:C44,E3:F44").ClearContents
  a = 3
For sut = 3 To 11
If sut = 4 Or sut = 8 Then sut = sut + 3
b = 2
For sat = 16 To 29
    b = 2
         If m.Cells(sat, sut) <> "" Then
        t.Cells(a, b) = t.Cells(a, b) + m.Cells(sat, sut)
        t.Cells(a, b + 1) = t.Cells(a, b + 1) + m.Cells(sat, sut + 1)
            a = a + 1
            End If
        Next
        Next
'xxxxxxxxxx
 a = 3
For sut = 3 To 11
If sut = 4 Or sut = 8 Then sut = sut + 3
b = 2
For sat = 36 To 49
    b = 5
         If m.Cells(sat, sut) <> "" Then
        t.Cells(a, b) = t.Cells(a, b) + m.Cells(sat, sut)
        t.Cells(a, b + 1) = t.Cells(a, b + 1) + m.Cells(sat, sut + 1)
            a = a + 1
            End If
        Next
        Next
Application.Calculation = xlCalculationAutomatic: Application.ScreenUpdating = True
MsgBox "İşlem Tamamlandı..."
End Sub

 

[manly]

Ellerinize sağlık hocam. Tam istediğim gibi oldu. Uğraştırdım sizi hakkınızı helal edin...

 

[vardar07]

Helal olsun. Bildiğimiz ve öğrendiğimiz kadarı ile yardımcı olmaya çalışıyoruz. Bir gün sizde birilerine yardımcı olursunuz. Kolay gelsin.