+- AccessTr.neT (https://accesstr.net)
+-- Forum: Microsoft Excel (https://accesstr.net/forum-microsoft-excel.html)
+--- Forum: Excel Cevaplanmış Soruları (https://accesstr.net/forum-excel-cevaplanmis-sorulari.html)
+--- Konu Başlığı: Tarihe Göre Toplam Almak (/konu-tarihe-gore-toplam-almak--88432.html)
Sayfalar:
1
2
RE: Tarihe Göre Toplam Almak - feraz - 22/05/2021
A sütununa formülle veri getirmenize gerek kalmadı kod ile getirip alfabetik sıralattım.
Kod hücrelere tek tek veri eklediği için yavaş biraz ve fazla veri varsa dizi ile hızlandırılır.
Sub Aktar()
Dim son As Long, i As Long
Dim syf As Worksheet, bul As Range
Set syf = ThisWorkbook.Sheets("Sayfa2")
Const satir_bas As Byte = 2
Const sifre As String = "123"
Const genelToplam As String = "GENEL TOPLAM:"
Const arananTarihHucre As Byte = 14
Application.ScreenUpdating = False
syf.Unprotect sifre
tekYapSirala
With ThisWorkbook.Sheets("Sayfa1")
syf.Range("B" & satir_bas & ":E" & Rows.Count).ClearContents
Set bul = syf.Range("B:B").Find(genelToplam, , , 1)
If Not bul Is Nothing Then
son = syf.Range("B:B").Find(genelToplam, , , , , xlPrevious).Row - 1
Else
son = syf.Range("A:A").Find("*", , , , , xlPrevious).Row + 1
End If
If son < satir_bas Then Exit Sub
If son = satir_bas Then son = satir_bas
For i = satir_bas To son
If syf.Cells(i, 1).Value <> "" Then syf.Cells(i, 2).Value = .Cells(14, "M").Value
syf.Cells(i, 3).Value = WorksheetFunction.SumIfs(.Range("D
"), _
.Range("A:A"), syf.Cells(i, 1).Value, _
.Range("B:B"), .Cells(arananTarihHucre, "M").Value)
syf.Cells(i, 4).Value = WorksheetFunction.SumIfs(.Range("i:i"), _
.Range("F:F"), syf.Cells(i, 1).Value, _
.Range("G:G"), .Cells(arananTarihHucre, "M").Value)
syf.Cells(i, 5).Value = syf.Cells(i, 3).Value + 0 - syf.Cells(i, 4).Value + 0
Next
son = syf.Range("A:A").Find("*", , , , , xlPrevious).Row + 1
syf.Range("B" & son).Value = genelToplam
son = syf.Range("B:B").Find(genelToplam, , , 1).Row
syf.Range("C" & son).Value = WorksheetFunction.Sum(syf.Range("C" & satir_bas & ":C" & son - 1))
syf.Range("D" & son).Value = WorksheetFunction.Sum(syf.Range("D" & satir_bas & "" & son - 1))
syf.Cells(son, "E").Value = syf.Cells(son, 3).Value - syf.Cells(son, 4).Value
End With
Application.ScreenUpdating = True
syf.Protect sifre
Set syf = Nothing: Set bul = Nothing
MsgBox "Biiti"
UserForm1.Show
End SubSub tekYapSirala()
Dim son1 As Long, aranan As String
Dim son2 As Long, i As Long
Dim dic As Object, dic2 As Object
Set dic = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("system.collections.arraylist")
With ThisWorkbook.Sheets("Sayfa1")
son1 = .Range("A:A").Find("*", , , , , xlPrevious).Row
dic.comparemode = 1
If son1 < 2 Then GoTo var
For i = 2 To son1
aranan = .Cells(i, 1).Value
If Not dic.exists(aranan) Then
dic.Add aranan, 0
dic2.Add aranan
End If
Next
var:
son2 = .Range("F:F").Find("*", , , , , xlPrevious).Row
If son2 < 2 Then GoTo var2
For i = 2 To son2
aranan = .Cells(i, "F").Value
If Not dic.exists(aranan) Then
dic.Add aranan, 0
dic2.Add aranan
End If
Next
var2:
If dic2.Count > 0 Then
dic2.Sort
ReDim arr(1 To dic2.Count, 1 To 1)
For i = 0 To dic2.Count - 1
arr(i + 1, 1) = dic2(i)
Next
ThisWorkbook.Sheets("Sayfa2").Range("A3").Resize(dic2.Count, 1).Value = arr
End If
End With
On Error Resume Next
Erase arr
Set dic = Nothing
Set dic2 = Nothing
On Error GoTo 0
End SubRe: Tarihe Göre Toplam Almak - feraz - 22/05/2021
Biraz daha hızlısı alttaki.
Sub Aktar()
Dim son As Long, i As Long
Dim syf As Worksheet, bul As Range
Set syf = ThisWorkbook.Sheets("Sayfa2")
Const satir_bas As Byte = 2
Const sifre As String = "123"
Const genelToplam As String = "GENEL TOPLAM:"
Const arananTarihHucre As Byte = 14
Application.ScreenUpdating = False
syf.Unprotect sifre
tekYapSirala
With ThisWorkbook.Sheets("Sayfa1")
syf.Range("B" & satir_bas & ":E" & Rows.Count).ClearContents
Set bul = syf.Range("B:B").Find(genelToplam, , , 1)
If Not bul Is Nothing Then
son = syf.Range("B:B").Find(genelToplam, , , , , xlPrevious).Row - 1
Else
son = syf.Range("A:A").Find("*", , , , , xlPrevious).Row + 1
End If
If son < satir_bas Then Exit Sub
If son = satir_bas Then son = satir_bas
ReDim arr(1 To son, 1 To 4)
For i = satir_bas To son
If syf.Cells(i, 1).Value <> "" Then arr(i - 1, 1) = .Cells(14, "M").Value
arr(i - 1, 2) = WorksheetFunction.SumIfs(.Range("D"), _
.Range("A:A"), syf.Cells(i, 1).Value, _
.Range("B:B"), .Cells(arananTarihHucre, "M").Value)
arr(i - 1, 3) = WorksheetFunction.SumIfs(.Range("i:i"), _
.Range("F:F"), syf.Cells(i, 1).Value, _
.Range("G:G"), .Cells(arananTarihHucre, "M").Value)
arr(i - 1, 4) = arr(i - 1, 2) + 0 - arr(i - 1, 3) + 0
Next
If UBound(arr) = 0 Then GoTo son
syf.Range("B2").Resize(UBound(arr), 4).Value = arr
son = syf.Range("A:A").Find("*", , , , , xlPrevious).Row + 1
syf.Range("B" & son).Value = genelToplam
son = syf.Range("B:B").Find(genelToplam, , , 1).Row
syf.Range("C" & son).Value = WorksheetFunction.Sum(syf.Range("C" & satir_bas & ":C" & son - 1))
syf.Range("D" & son).Value = WorksheetFunction.Sum(syf.Range("D" & satir_bas & "" & son - 1))
syf.Cells(son, "E").Value = syf.Cells(son, 3).Value - syf.Cells(son, 4).Value
End With
son:
Application.ScreenUpdating = True
syf.Protect sifre
Set syf = Nothing: Set bul = Nothing
UserForm1.Show
End Sub
Sub tekYapSirala()
Dim son1 As Long, aranan As String
Dim son2 As Long, i As Long
Dim dic As Object, dic2 As Object
Set dic = CreateObject("Scripting.dictionary")
Set dic2 = CreateObject("system.collections.arraylist")
With ThisWorkbook.Sheets("Sayfa1")
son1 = .Range("A:A").Find("*", , , , , xlPrevious).Row
dic.comparemode = 1
If son1 < 2 Then GoTo var
For i = 2 To son1
aranan = .Cells(i, 1).Value
If Not dic.exists(aranan) Then
dic.Add aranan, 0
dic2.Add aranan
End If
Next
var:
son2 = .Range("F:F").Find("*", , , , , xlPrevious).Row
If son2 < 2 Then GoTo var2
For i = 2 To son2
aranan = .Cells(i, "F").Value
If Not dic.exists(aranan) Then
dic.Add aranan, 0
dic2.Add aranan
End If
Next
var2:
If dic2.Count > 0 Then
dic2.Sort
ReDim arr(1 To dic2.Count, 1 To 1)
For i = 0 To dic2.Count - 1
arr(i + 1, 1) = dic2(i)
Next
ThisWorkbook.Sheets("Sayfa2").Range("A3").Resize(dic2.Count, 1).Value = arr
End If
End With
On Error Resume Next
Erase arr
Set dic = Nothing
Set dic2 = Nothing
On Error GoTo 0
End Sub
RE: Tarihe Göre Toplam Almak - m_demir - 22/05/2021
Çok, çok teşekkürler Hocam ellerinize sağlık tam istediğim gibi olmuş.
Hocam konuyu taşıyabilirsiniz. Saygılarımla iyi günler diliyorum.
RE: Tarihe Göre Toplam Almak - feraz - 22/05/2021
Rica ederim,kolay gelsin.