Makro İle İcmal Almak - hayalibey - 21/05/2021
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 .
RE: Makro İle İcmal Almak - feraz - 22/05/2021
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
RE: Makro İle İcmal Almak - hayalibey - 22/05/2021
Zafer Hocam siz bu işin üstadısınız. Elinize kolunuza yüreğinize sağlık. Allah'a emanet olun
RE: Makro İle İcmal Almak - feraz - 22/05/2021
Rica ederim abey,kolay gelsin.
|