Skip to main content

AccessTr.neT


Makro İle İcmal Almak

Makro İle İcmal Almak

Çözüldü #1
Herkese Merhaba
Toplam sayfası C sütunda benzersiz siciller var
D - P aralığında ay isimleri var.
Bu ay isimleri ile birebir aynı sayfa isimleri mevcut .

Yapamadığım
Ayların isimlerinin olduğu sayfalarda C sütunundaki siciller ile toplam sayfası C sütunundaki siciller aynı ise
1. Işlem: ayların yazılı olduğu sayfalardaki E Sütununda yazan sayı, toplam sayfasındaki ilgili ay sütununun altına ilgili sicilin karşısına yazılacak.
Eğer ilgili ayda o sicil yoksa toplam sayfası ilgili ayın olduğu hücre boş kalacak.
2. Işlem: Toplam sayfası F -Q aralığı toplanıp E sütununa yazılacak .
.rar 2021 YILLIK ÇİZELGE.rar (Dosya Boyutu: 48,26 KB | İndirme Sayısı: 2)
Son Düzenleme: 21/05/2021, 20:00, Düzenleyen: hayalibey.
Cevapla
#2
Merhaba.
Kodun birisi yavaş diğeri ise hızlı çalışır test edin sonuçları.

Sub Test1() 'yavas

Dim syf As Worksheet
Dim i As Long, k As Byte
Dim bul As Range, son As Long

With ThisWorkbook.Sheets("TOPLAM")
    .Range("E3:Q" & Rows.Count).ClearContents
    son = .Range("C:C").Find("*", , , , , xlPrevious).Row + 1
    For Each syf In ThisWorkbook.Sheets
        If syf.Name = "TOPLAM" Then GoTo var
        For k = 6 To 17
            For i = 3 To son
                If .Cells(2, k).Value = syf.Name Then
                    Set bul = syf.Columns(3).Find(.Cells(i, 3).Value, , , 1)
                    If Not bul Is Nothing Then .Cells(i, k).Value = syf.Cells(bul.Row, "E").Value
                End If
            .Cells(i, "E").Value = WorksheetFunction.Sum(.Range(.Cells(i, "F"), .Cells(i, "Q")))
            Next
        Next
var:
    Next
    .Rows(son).ClearContents
End With

Set bul = Nothing
MsgBox ""
End Sub


Sub Test2() 'hizli

Dim syf As Worksheet
Dim i As Long, k As Byte
Dim bul As Range, son As Long

With ThisWorkbook.Sheets("TOPLAM")
    .Range("E3:Q" & Rows.Count).ClearContents
    son = .Range("C:C").Find("*", , , , , xlPrevious).Row + 1
    ReDim arr(1 To son, 1 To 12)
    For Each syf In ThisWorkbook.Sheets
        If syf.Name = "TOPLAM" Then GoTo var
        For k = 6 To 17
            For i = 3 To son
                If .Cells(2, k).Value = syf.Name Then
                    Set bul = syf.Columns(3).Find(.Cells(i, 3).Value, , , 1)
                    If Not bul Is Nothing Then arr(i - 2, k - 5) = syf.Cells(bul.Row, "E").Value
                End If
            Next
        Next
var:
    Next
    If UBound(arr) > 0 Then .Range("F3").Resize(son, 12).Value = arr
    ReDim arr2(1 To son, 1 To 1)
    i = 0
    For i = 3 To son
        arr2(i - 2, 1) = WorksheetFunction.Sum(.Range(.Cells(i, "F"), .Cells(i, "Q")))
    Next
    If UBound(arr2) > 0 Then .Range("E3").Resize(son, 1).Value = arr2
    .Rows(son).ClearContents
End With
On Error Resume Next
Erase arr: Erase arr2
Set bul = Nothing
On Error GoTo 0
MsgBox ""
End Sub
Cevapla
#3
Zafer Hocam siz bu işin üstadısınız. Elinize kolunuza yüreğinize sağlık. Allah'a emanet olun
Cevapla
#4
Rica ederim abey,kolay gelsin.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task