DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Ömer Bey merhaba,
Ömer Bey merhaba,
Ziynettin Bey merhaba, ilginiz için teşekkür ederim.
Sub test()
Set s1 = Sheets("GENEL")
Set S2 = Sheets("FİRMALAR")
Set d1 = CreateObject("Scripting.dictionary")
Set d2 = CreateObject("Scripting.dictionary")
Set d3 = CreateObject("Scripting.dictionary")
On Error Resume Next
a = s1.Range("A2:M" & s1.Cells(Rows.Count, 1).End(3).Row).Value
For i = UBound(a) To 1 Step -1
If Month(a(i, 2)) = 9 Then
krt = a(i, 1)
If d1.exists(krt) Then
If a(i, 2) > a(d1(krt), 2) Then d1(krt) = i
Else
d1(krt) = i
End If
End If
If Month(a(i, 2)) = 10 Then
krt = a(i, 1)
If d2.exists(krt) Then
If a(i, 2) > a(d2(krt), 2) Then d2(krt) = i
Else
d2(krt) = i
End If
End If
If Month(a(i, 2)) = 11 Then
krt = a(i, 1)
If d3.exists(krt) Then
If a(i, 2) > a(d3(krt), 2) Then d3(krt) = i
Else
d3(krt) = i
End If
End If
Next i
b = S2.Range("A4:A" & S2.Cells(Rows.Count, 1).End(3).Row).Value
ReDim c(1 To UBound(b), 1 To 3)
For i = 1 To UBound(b)
krt = b(i, 1)
k1 = CDbl(a(d1(krt), 13))
k2 = CDbl(a(d2(krt), 13))
k3 = CDbl(a(d3(krt), 13))
c(i, 1) = k1
If k2 = 0 Then c(i, 2) = k2 Else c(i, 2) = k2 - k1
If k3 = 0 Then c(i, 3) = k3 Else c(i, 3) = k3 - k2
k1 = 0
k2 = 0
k3 = 0
Next i
S2.[N4].Resize(UBound(b), 3) = c
MsgBox "İşlem tamam.", vbInformation
End Sub
Formül ile çözüme ihtiyacınız olursa, ekli dosyayı inceleyiniz.
Hocam dediğiniz sonuç doğru, ay toplamları sadece o ayın bakiyesini verecek sadece geçen ay önceki bütün ayları alacak.
Turist hocam merhaba,
Sağolun,
Dosyanız.
Ziynettin Hocam merhaba, ellerinize sağlık. Yarın iş yerinde gerçek programda deneyeceğim. Şu anda istediğim gibi görünüyor.
Ziynettin Hocam merhaba, İş yerinde gerçek programda denedim. Bazılarında olmadık sonuçlar çıktı. Bazıları da doğru çıktı. İlginiz için teşekkürler. Koddan anlamadığım için müdahale edemiyorum, sanırım formülle yapacağım.
Sub SOYLU_BRN()
Set f = Sheets("FİRMALAR")
Set g = Sheets("GENEL")
Set b = Sheets("BARAN")
If g.AutoFilterMode = True Then g.AutoFilterMode = False
fson = f.Cells(Rows.Count, 1).End(3).Row
gson = g.Cells(Rows.Count, 1).End(3).Row
f.Range("J4:L" & fson).ClearContents
eskiilk = WorksheetFunction.Min(g.[B:B]) 'CDate("1/" & Month(Date) - 1 & "/" & Year(Date))
eskison = CDate("1/" & Month(Date) & "/" & Year(Date)) - 1
buayilk = CDate("1/" & Month(Date) & "/" & Year(Date))
buayson = CDate("1/" & Month(Date) + 1 & "/" & Year(Date)) - 1
yeniilk = CDate("1/" & Month(Date) + 1 & "/" & Year(Date))
yenison = WorksheetFunction.Max(g.[B:B]) 'CDate("1/" & Month(Date) + 2 & "/" & Year(Date)) - 1
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
For fsat = 4 To f.Cells(Rows.Count, 1).End(3).Row
firma = f.Cells(fsat, 1)
For kr = 1 To 3
If kr = 1 Then kriter1 = eskiilk: kriter2 = eskison
If kr = 2 Then kriter1 = buayilk: kriter2 = buayson
If kr = 3 Then kriter1 = yeniilk: kriter2 = yenison
g.Range("A1:P" & gson).AutoFilter Field:=1, Criteria1:=firma
g.Range("A1:P" & gson).AutoFilter Field:=2, Criteria1:=">=" & _
CLng(kriter1), Operator:=xlAnd, Criteria2:="<=" & CLng(kriter2)
bakiye = 0
If g.Cells(Rows.Count, 1).End(3).Row > 1 Then
b.Cells.Clear
g.Range("A2:M" & gson).SpecialCells(xlCellTypeVisible).Copy
b.[A1].PasteSpecial Paste:=xlPasteValues
b.Range("A1:M" & Rows.Count).Sort b.[B1], 1
bakiye = b.Cells(b.Cells(Rows.Count, 1).End(3).Row, "M")
End If
If kr = 3 Then
f.Cells(fsat, kr + 9) = bakiye - f.Cells(fsat, kr + 8)
Else
f.Cells(fsat, kr + 9) = bakiye
End If
Next
Next
If g.AutoFilterMode = True Then g.AutoFilterMode = False
b.Cells.Clear: f.Activate
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İŞLEM TAMAMLANDI.", vbInformation, "..:: Ömer BARAN ::.."
End SubÖmer Bey merhaba, ilgi ve alakanız için teşekkürler. Şöyle bir hata aldım. Ekran resmini ekledim. Bu kodu tam olarak nereye eklemeliyim? Programın aslını özelden gönderebilirim.
Sub SOYLU_BRN2()
Set f = Sheets("FİRMALAR"): Set g = Sheets("GENEL")
fson = f.Cells(Rows.Count, 1).End(3).Row: gson = g.Cells(Rows.Count, 1).End(3).Row
f.Range("J4:L" & fson).NumberFormat = "#,##0.00_ ;[Red]-#,##0.00 "
If f.Cells(Rows.Count, 10).End(3).Row > 3 Then f.Range("J4:L" & Rows.Count).ClearContents
Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
f.[J4].Formula = "=ROUND(SUMPRODUCT((GENEL!$A$2:$A$" & gson & "=$A4)*(GENEL!$B$2:$B$" & _
gson & "<EOMONTH(TODAY(),-1)+1)*(GENEL!$L$2:$L$" & gson & ")),2)"
f.[K4].Formula = "=ROUND(SUMPRODUCT((GENEL!$A$2:$A$" & gson & "=$A4)*((GENEL!$B$2:$B$" & gson & _
"<=EOMONTH(TODAY(),0))-(GENEL!$B$2:$B$" & gson & "<EOMONTH(TODAY(),-1)+1))*(GENEL!$L$2:$L$" & gson & ")),2)"
f.[L4].Formula = "=ROUND(SUMPRODUCT((GENEL!$A$2:$A$" & gson & "=$A4)*(GENEL!$B$2:$B$" & gson & _
">EOMONTH(TODAY(),0))*(GENEL!$B$2:$B$" & gson & "<=EOMONTH(TODAY(),1))*(GENEL!$L$2:$L$" & gson & ")),2)"
f.Range("J4:L4").AutoFill Destination:=f.Range("J4:L" & fson)
f.Range("J4:L" & fson).Calculate
f.Range("J4:L" & fson).Value = f.Range("J4:L" & fson).Value
Application.ScreenUpdating = True: Application.Calculation = xlCalculationAutomatic
MsgBox "İŞLEM TAMAMLANDI.", vbInformation, "..:: Ömer BARAN ::.."
End Sub