I'm displaying data in a listview and want to add up the initial and debit balance data and then subtract the credit (starting balance+Debit-Credit) in the last column, but I didn't manage to add up all the data perfectly.
where is my mistake?
Please also correct the code that I made.
greetings to the masters
This my Code
Private Sub Cmd_Kas_Click()
Dim ListItem As MSComctlLib.ListItem
Dim dtA As Date, dtX As Date
Dim xn As Long, rw As Long, rb As Long
Dim RngData As Range
Dim RowCount As Long
Dim colCount As Long
Dim tHA As Date
Dim yr As Integer
Dim Bng As Currency, Bya As Currency, Dnd As Currency
Dim sbPinj As Currency
Dim sbTbg As Currency, sbDep As Currency, sbSpr As Currency
Dim sbBgTbg As Currency, sbBgDep As Currency, sbBgSpr As Currency
Dim sbAgt As Currency, sbLain As Currency
Dim AwlKas As Currency, xTotal As Currency
Dim xr As Range, xf As Range, xt As Range
Set wd = Sheets("Data")
Dim xj As Double, xa As Double, xb As Double
dtA = wd.Range("D8").Value
dtX = wd.Range("E8").Value
yr = Year(dtA)
Select Case yr
Case Is = Year(Date)
Set wt = Sheets("LapNL")
Case Else
Set wt = Sheets("LapAkun")
End Select
Set rg = wt.Range("C2", wt.Cells(wt.Rows.Count, 7).End(xlUp))
Set xr = wd.Range("D9:E10")
Set xf = wd.Range("C9:E10")
Set xt = wd.Range("D9:F10")
Set ws = Sheets("DBPinj")
wd.Cells(7, 4) = ws.Cells(1, 3)
wd.Cells(7, 5) = ws.Cells(1, 3)
Application.Calculation = xlCalculationManual
'On Error Resume Next
AwlKas = Application.WorksheetFunction.VLookup("I.1.1", rg, 4, False)
sbPinj = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("H1"), xr) _
- Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xr)
Bya = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("I1"), xr)
Bng = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("J1"), xr)
Dnd = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("K1"), xr)
Set ws = Nothing
Dim xs As Double, xl As Double
xs = 0
Dim ars(1 To 7) As String
ars(1) = "DBTbg"
ars(2) = "DBBgTbg"
ars(3) = "DBDep"
ars(4) = "DBBgDep"
ars(5) = "DBSpr"
ars(6) = "DBBgSpr"
ars(7) = "DBAgt"
For l = 1 To 7
Set ws = Sheets(ars(l))
If Left(ws.Name, 3) = "DBB" Then
xl = -Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xr)
Else
xl = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("H1"), xr) _
- Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xr)
End If
xs = xs + xl
Next l
Set ws = Nothing
Set ws = Sheets("DBLain")
wd.Cells(9, 3) = ws.Cells(1, 4)
wd.Cells(9, 6) = ws.Cells(1, 5)
wd.Cells(10, 3) = "'=I.1.1"
wd.Cells(10, 6) = "'=I.1.1"
sbLain = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xf) _
- Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xt)
xTotal = sbPinj + xs + sbLain + Bya + Bng + Dnd
With Me
.LstKas.ListItems.Clear
.LblPrs.caption = "Sedang dalam proses, silakan tunggu.."
.FrKet.Visible = True
DoEvents
On Error Resume Next
Application.ScreenUpdating = False
With .LstKas
Set ListItem = LstKas.ListItems.Add(, , " ***)", , 3)
ListItem.SubItems(1) = Format(wd.Range("D8"), "DD-MM-YYYY")
ListItem.SubItems(2) = wd.Range("D8")
ListItem.SubItems(4) = "SALDO AWAL"
ListItem.SubItems(5) = 0
ListItem.SubItems(6) = 0
Set Sh = Sheets("DBTbg")
Set sht = Sheets("DBBgTbg")
Set rg = Sh.Range("B1").CurrentRegion
Set rng = sht.Range("B1").CurrentRegion
'Start-----------------------------------------
'Pinjaman...................
Set ws = Sheets("DBPinj")
ws.Activate
For ii = 2 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
tHA = Format(ws.Cells(ii, 3).Value, "mm/dd/yyyy")
If tHA >= dtA Then
rw = ii
GoTo Nxt
End If
Next ii
Nxt:
Set ws = Sheets("DBPinj")
For i = 2 To ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For j = 7 To 11
If Format(ws.Cells(i, 3), "mm/dd/yyyy") >= dtA _
And Format(ws.Cells(i, 3), "mm/dd/yyyy") <= dtX _
And ws.Cells(i, j).Value <> 0 Then
Set ListItem = LstKas.ListItems.Add(, , ws.Cells(i, 2).Value, , 3)
ListItem.SubItems(1) = Format(ws.Cells(i, 3), "DD-MM-YYYY")
ListItem.SubItems(2) = ws.Cells(i, 3)
If j = 9 Then
ListItem.SubItems(3) = "IV.1.1"
ElseIf j = 10 Then
ListItem.SubItems(3) = "IV.1.3"
ElseIf j = 11 Then
ListItem.SubItems(3) = "IV.1.5"
Else
ListItem.SubItems(3) = "I.1.4"
End If
ListItem.SubItems(4) = ws.Cells(i, 5)
If j = 7 Then
ListItem.SubItems(5) = 0
ListItem.SubItems(6) = Replace(Format(ws.Cells(i, j), "#,##0"), ",", ".")
Else
ListItem.SubItems(5) = Replace(Format(ws.Cells(i, j), "#,##0"), ",", ".")
ListItem.SubItems(6) = 0
End If
End If
Next j
Next i
Set ws = Nothing
Dim arsh(1 To 4) As String
arsh(1) = "DBAgt"
arsh(2) = "DBTbg"
arsh(3) = "DBDep"
arsh(4) = "DBSpr"
'Tabungan...................
For jj = 1 To 4
Set ws = Sheets(arsh(jj))
ws.Activate
For ii = 2 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
tHA = Format(ws.Cells(ii, 3).Value, "mm/dd/yyyy")
If tHA >= dtA Then
rw = ii
GoTo Nxt1
End If
Next ii
Application.ScreenUpdating = True
Nxt1:
ws.Range("B1").Select
For i = 2 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
If Format(ws.Cells(i, 3), "mm/dd/yyyy") >= dtA And Format(ws.Cells(i, 3), "mm/dd/yyyy") <= dtX Then
Set ListItem = LstKas.ListItems.Add(, , ws.Cells(i, 2).Value, , 3)
ListItem.SubItems(1) = Format(ws.Cells(i, 3), "DD-MM-YYYY")
ListItem.SubItems(2) = ws.Cells(i, 3)
ListItem.SubItems(4) = ws.Cells(i, 5)
' ListItem.SubItems(5) = Replace(Format(ws.Cells(i, 8), "#,##0"), ",", ".")
' ListItem.SubItems(6) = Replace(Format(ws.Cells(i, 7), "#,##0"), ",", ".")
ListItem.SubItems(5) = Format(ws.Cells(i, 8), "#,##0")
ListItem.SubItems(6) = Format(ws.Cells(i, 7), "#,##0")
If jj = 2 Then
ListItem.SubItems(3) = "II.1.1"
ElseIf jj = 3 Then
ListItem.SubItems(3) = "II.1.2.1"
ElseIf jj = 4 Then
ListItem.SubItems(3) = "II.1.2.2"
Else
ListItem.SubItems(3) = ws.Cells(i, 6)
End If
End If
Next i
Next jj
Dim x As Integer
Dim arsht(1 To 3) As String
arsht(1) = "DBBgTbg"
arsht(2) = "DBBgDep"
arsht(3) = "DBBgSpr"
'Bunga...................
For x = 1 To 3
Set ws = Sheets(arsht(x))
ws.Activate
Application.ScreenUpdating = True
Nxt2:
For i = 2 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
If Format(ws.Cells(i, 3), "mm/dd/yyyy") >= dtA And Format(ws.Cells(i, 3), "mm/dd/yyyy") <= dtX Then
If ws.Cells(i, 7).Value > 0 Then
Set ListItem = LstKas.ListItems.Add(, , ws.Cells(i, 2).Value, , 3)
ListItem.SubItems(1) = Format(ws.Cells(i, 3), "DD-MM-YYYY")
ListItem.SubItems(2) = ws.Cells(i, 3)
If x = 1 Then
ListItem.SubItems(3) = "V.1"
Else
ListItem.SubItems(3) = "V.2"
End If
ListItem.SubItems(4) = ws.Cells(i, 5)
ListItem.SubItems(5) = Replace(Format(ws.Cells(i, 8), "#,##0"), ",", ".")
ListItem.SubItems(6) = Replace(Format(ws.Cells(i, 7), "#,##0"), ",", ".")
End If
End If
Next i
Next x
Set ws = Sheets("DBLain")
ws.Activate
For i = 2 To ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
If Format(ws.Cells(i, 3).Value, "mm/dd/yyyy") >= dtA And Format(ws.Cells(i, 3).Value, "mm/dd/yyyy") <= dtX Then
If UCase(ws.Cells(i, 4)) = "I.1.1" Or UCase(ws.Cells(i, 5)) = "I.1.1" Then
Set ListItem = LstKas.ListItems.Add(, , ws.Cells(i, 2).Value, , 3)
ListItem.SubItems(1) = Format(ws.Cells(i, 3), "DD-MM-YYYY")
If UCase(ws.Cells(i, 4)) = "I.1.1" Then
ListItem.SubItems(2) = ws.Cells(i, 3)
ListItem.SubItems(3) = ws.Cells(i, 5)
ListItem.SubItems(4) = ws.Cells(i, 6)
ListItem.SubItems(5) = Replace(Format(ws.Cells(i, 7), "#,##0"), ",", ".")
ListItem.SubItems(6) = 0
ElseIf UCase(ws.Cells(i, 5)) = "I.1.1" Then
ListItem.SubItems(2) = ws.Cells(i, 3)
ListItem.SubItems(3) = ws.Cells(i, 4)
ListItem.SubItems(4) = ws.Cells(i, 6)
ListItem.SubItems(5) = 0
ListItem.SubItems(6) = Replace(Format(ws.Cells(i, 7), "#,##0"), ",", ".")
End If
End If
End If
Next i
End With
Dim nColDb As Long, nColKr As Long
Dim ColDebet As Double, ColKredit As Double
For Each ListItem In LstKas.ListItems
nColDb = Replace(nColDb, ".", "") + CLng(Replace(ListItem.SubItems(5), ".", ""))
nColKr = Replace(nColKr, ".", "") + CLng(Replace(ListItem.SubItems(6), ".", ""))
ListItem.SubItems(7) = Replace(Format(nColDb - nColKr + (AwlKas + xTotal), "#,##0"), ",", ".")
Next
TxtPosDbt = Replace(Format(nColDb, "#,##0"), ",", ".")
TxtPosKrd = Replace(Format(nColKr, "#,##0"), ",", ".")
TxtSelisih = Replace(Format(nColDb - nColKr, "#,##0"), ",", ".")
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Set ws = Nothing
Set wd = Nothing
On Error GoTo 0
FrKet.Visible = False
End With
End Sub
where is my mistake?
Please also correct the code that I made.
greetings to the masters
This my Code
Private Sub Cmd_Kas_Click()
Dim ListItem As MSComctlLib.ListItem
Dim dtA As Date, dtX As Date
Dim xn As Long, rw As Long, rb As Long
Dim RngData As Range
Dim RowCount As Long
Dim colCount As Long
Dim tHA As Date
Dim yr As Integer
Dim Bng As Currency, Bya As Currency, Dnd As Currency
Dim sbPinj As Currency
Dim sbTbg As Currency, sbDep As Currency, sbSpr As Currency
Dim sbBgTbg As Currency, sbBgDep As Currency, sbBgSpr As Currency
Dim sbAgt As Currency, sbLain As Currency
Dim AwlKas As Currency, xTotal As Currency
Dim xr As Range, xf As Range, xt As Range
Set wd = Sheets("Data")
Dim xj As Double, xa As Double, xb As Double
dtA = wd.Range("D8").Value
dtX = wd.Range("E8").Value
yr = Year(dtA)
Select Case yr
Case Is = Year(Date)
Set wt = Sheets("LapNL")
Case Else
Set wt = Sheets("LapAkun")
End Select
Set rg = wt.Range("C2", wt.Cells(wt.Rows.Count, 7).End(xlUp))
Set xr = wd.Range("D9:E10")
Set xf = wd.Range("C9:E10")
Set xt = wd.Range("D9:F10")
Set ws = Sheets("DBPinj")
wd.Cells(7, 4) = ws.Cells(1, 3)
wd.Cells(7, 5) = ws.Cells(1, 3)
Application.Calculation = xlCalculationManual
'On Error Resume Next
AwlKas = Application.WorksheetFunction.VLookup("I.1.1", rg, 4, False)
sbPinj = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("H1"), xr) _
- Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xr)
Bya = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("I1"), xr)
Bng = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("J1"), xr)
Dnd = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("K1"), xr)
Set ws = Nothing
Dim xs As Double, xl As Double
xs = 0
Dim ars(1 To 7) As String
ars(1) = "DBTbg"
ars(2) = "DBBgTbg"
ars(3) = "DBDep"
ars(4) = "DBBgDep"
ars(5) = "DBSpr"
ars(6) = "DBBgSpr"
ars(7) = "DBAgt"
For l = 1 To 7
Set ws = Sheets(ars(l))
If Left(ws.Name, 3) = "DBB" Then
xl = -Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xr)
Else
xl = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("H1"), xr) _
- Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xr)
End If
xs = xs + xl
Next l
Set ws = Nothing
Set ws = Sheets("DBLain")
wd.Cells(9, 3) = ws.Cells(1, 4)
wd.Cells(9, 6) = ws.Cells(1, 5)
wd.Cells(10, 3) = "'=I.1.1"
wd.Cells(10, 6) = "'=I.1.1"
sbLain = Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xf) _
- Application.DSum(ws.Range("B1").CurrentRegion, ws.Range("G1"), xt)
xTotal = sbPinj + xs + sbLain + Bya + Bng + Dnd
With Me
.LstKas.ListItems.Clear
.LblPrs.caption = "Sedang dalam proses, silakan tunggu.."
.FrKet.Visible = True
DoEvents
On Error Resume Next
Application.ScreenUpdating = False
With .LstKas
Set ListItem = LstKas.ListItems.Add(, , " ***)", , 3)
ListItem.SubItems(1) = Format(wd.Range("D8"), "DD-MM-YYYY")
ListItem.SubItems(2) = wd.Range("D8")
ListItem.SubItems(4) = "SALDO AWAL"
ListItem.SubItems(5) = 0
ListItem.SubItems(6) = 0
Set Sh = Sheets("DBTbg")
Set sht = Sheets("DBBgTbg")
Set rg = Sh.Range("B1").CurrentRegion
Set rng = sht.Range("B1").CurrentRegion
'Start-----------------------------------------
'Pinjaman...................
Set ws = Sheets("DBPinj")
ws.Activate
For ii = 2 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
tHA = Format(ws.Cells(ii, 3).Value, "mm/dd/yyyy")
If tHA >= dtA Then
rw = ii
GoTo Nxt
End If
Next ii
Nxt:
Set ws = Sheets("DBPinj")
For i = 2 To ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
For j = 7 To 11
If Format(ws.Cells(i, 3), "mm/dd/yyyy") >= dtA _
And Format(ws.Cells(i, 3), "mm/dd/yyyy") <= dtX _
And ws.Cells(i, j).Value <> 0 Then
Set ListItem = LstKas.ListItems.Add(, , ws.Cells(i, 2).Value, , 3)
ListItem.SubItems(1) = Format(ws.Cells(i, 3), "DD-MM-YYYY")
ListItem.SubItems(2) = ws.Cells(i, 3)
If j = 9 Then
ListItem.SubItems(3) = "IV.1.1"
ElseIf j = 10 Then
ListItem.SubItems(3) = "IV.1.3"
ElseIf j = 11 Then
ListItem.SubItems(3) = "IV.1.5"
Else
ListItem.SubItems(3) = "I.1.4"
End If
ListItem.SubItems(4) = ws.Cells(i, 5)
If j = 7 Then
ListItem.SubItems(5) = 0
ListItem.SubItems(6) = Replace(Format(ws.Cells(i, j), "#,##0"), ",", ".")
Else
ListItem.SubItems(5) = Replace(Format(ws.Cells(i, j), "#,##0"), ",", ".")
ListItem.SubItems(6) = 0
End If
End If
Next j
Next i
Set ws = Nothing
Dim arsh(1 To 4) As String
arsh(1) = "DBAgt"
arsh(2) = "DBTbg"
arsh(3) = "DBDep"
arsh(4) = "DBSpr"
'Tabungan...................
For jj = 1 To 4
Set ws = Sheets(arsh(jj))
ws.Activate
For ii = 2 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
tHA = Format(ws.Cells(ii, 3).Value, "mm/dd/yyyy")
If tHA >= dtA Then
rw = ii
GoTo Nxt1
End If
Next ii
Application.ScreenUpdating = True
Nxt1:
ws.Range("B1").Select
For i = 2 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
If Format(ws.Cells(i, 3), "mm/dd/yyyy") >= dtA And Format(ws.Cells(i, 3), "mm/dd/yyyy") <= dtX Then
Set ListItem = LstKas.ListItems.Add(, , ws.Cells(i, 2).Value, , 3)
ListItem.SubItems(1) = Format(ws.Cells(i, 3), "DD-MM-YYYY")
ListItem.SubItems(2) = ws.Cells(i, 3)
ListItem.SubItems(4) = ws.Cells(i, 5)
' ListItem.SubItems(5) = Replace(Format(ws.Cells(i, 8), "#,##0"), ",", ".")
' ListItem.SubItems(6) = Replace(Format(ws.Cells(i, 7), "#,##0"), ",", ".")
ListItem.SubItems(5) = Format(ws.Cells(i, 8), "#,##0")
ListItem.SubItems(6) = Format(ws.Cells(i, 7), "#,##0")
If jj = 2 Then
ListItem.SubItems(3) = "II.1.1"
ElseIf jj = 3 Then
ListItem.SubItems(3) = "II.1.2.1"
ElseIf jj = 4 Then
ListItem.SubItems(3) = "II.1.2.2"
Else
ListItem.SubItems(3) = ws.Cells(i, 6)
End If
End If
Next i
Next jj
Dim x As Integer
Dim arsht(1 To 3) As String
arsht(1) = "DBBgTbg"
arsht(2) = "DBBgDep"
arsht(3) = "DBBgSpr"
'Bunga...................
For x = 1 To 3
Set ws = Sheets(arsht(x))
ws.Activate
Application.ScreenUpdating = True
Nxt2:
For i = 2 To ws.Cells(ws.Rows.Count, 3).End(xlUp).Row
If Format(ws.Cells(i, 3), "mm/dd/yyyy") >= dtA And Format(ws.Cells(i, 3), "mm/dd/yyyy") <= dtX Then
If ws.Cells(i, 7).Value > 0 Then
Set ListItem = LstKas.ListItems.Add(, , ws.Cells(i, 2).Value, , 3)
ListItem.SubItems(1) = Format(ws.Cells(i, 3), "DD-MM-YYYY")
ListItem.SubItems(2) = ws.Cells(i, 3)
If x = 1 Then
ListItem.SubItems(3) = "V.1"
Else
ListItem.SubItems(3) = "V.2"
End If
ListItem.SubItems(4) = ws.Cells(i, 5)
ListItem.SubItems(5) = Replace(Format(ws.Cells(i, 8), "#,##0"), ",", ".")
ListItem.SubItems(6) = Replace(Format(ws.Cells(i, 7), "#,##0"), ",", ".")
End If
End If
Next i
Next x
Set ws = Sheets("DBLain")
ws.Activate
For i = 2 To ws.Cells(ws.Rows.Count, 4).End(xlUp).Row
If Format(ws.Cells(i, 3).Value, "mm/dd/yyyy") >= dtA And Format(ws.Cells(i, 3).Value, "mm/dd/yyyy") <= dtX Then
If UCase(ws.Cells(i, 4)) = "I.1.1" Or UCase(ws.Cells(i, 5)) = "I.1.1" Then
Set ListItem = LstKas.ListItems.Add(, , ws.Cells(i, 2).Value, , 3)
ListItem.SubItems(1) = Format(ws.Cells(i, 3), "DD-MM-YYYY")
If UCase(ws.Cells(i, 4)) = "I.1.1" Then
ListItem.SubItems(2) = ws.Cells(i, 3)
ListItem.SubItems(3) = ws.Cells(i, 5)
ListItem.SubItems(4) = ws.Cells(i, 6)
ListItem.SubItems(5) = Replace(Format(ws.Cells(i, 7), "#,##0"), ",", ".")
ListItem.SubItems(6) = 0
ElseIf UCase(ws.Cells(i, 5)) = "I.1.1" Then
ListItem.SubItems(2) = ws.Cells(i, 3)
ListItem.SubItems(3) = ws.Cells(i, 4)
ListItem.SubItems(4) = ws.Cells(i, 6)
ListItem.SubItems(5) = 0
ListItem.SubItems(6) = Replace(Format(ws.Cells(i, 7), "#,##0"), ",", ".")
End If
End If
End If
Next i
End With
Dim nColDb As Long, nColKr As Long
Dim ColDebet As Double, ColKredit As Double
For Each ListItem In LstKas.ListItems
nColDb = Replace(nColDb, ".", "") + CLng(Replace(ListItem.SubItems(5), ".", ""))
nColKr = Replace(nColKr, ".", "") + CLng(Replace(ListItem.SubItems(6), ".", ""))
ListItem.SubItems(7) = Replace(Format(nColDb - nColKr + (AwlKas + xTotal), "#,##0"), ",", ".")
Next
TxtPosDbt = Replace(Format(nColDb, "#,##0"), ",", ".")
TxtPosKrd = Replace(Format(nColKr, "#,##0"), ",", ".")
TxtSelisih = Replace(Format(nColDb - nColKr, "#,##0"), ",", ".")
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Set ws = Nothing
Set wd = Nothing
On Error GoTo 0
FrKet.Visible = False
End With
End Sub
