Dim xlApp, wb, fil
Dim ws_old, ws_new, rng, cel
Const xlSortOnValues = 0
Const xlTopToBottom = 1
Const xlPinYin = 1
Const xlSortNormal = 0
Const xlAscending = 1
Const xlDescending = 2
Const xlYes = 1
Const xlUp = -4162
Const xlDown = -4121
Const xlGuess = 0
fil = "C:\Downloads\dfile.CSV"
Set xlApp = CreateObject("Excel.Application")
Set wb = xlApp.Workbooks.Open(fil)
xlApp.Visible = True
xlApp.ScreenUpdating = False
Set ws_old = xlApp.ActiveSheet
Set ws_new = wb.Worksheets.Add
ws_new.Range("A1").Resize(1, 7).Value = Array("Location", "Credit/Debit", "Date", "Check Num", "Description ", "Account", "Amount")
Set rng = ws_old.UsedRange
rng.Sort ws_old.Range("D1"), xlAscending, ws_old.Range("A1"), , xlAscending, ws_old.Range("H1"), xlDescending, xlYes
Set rng = ws_old.Range(ws_old.Range("A2"), ws_old.Cells(ws_old.Rows.Count, "A").End(-4162)) ' xlUp = -4162
For Each cel In rng
With ws_new.Cells(ws_new.Rows.Count, "C").End(-4162).Offset(1, -2) ' xlUp = -4162
.Offset(0, 2).Value = cel
.Offset(0, 4).Value = Trim(Replace(Replace(cel.Offset(0, 10), "/", ""), "<BR>", ""))
If InStr(cel.Offset(0, 10), "/") > 0 Then
tmp = Trim(Left(cel.Offset(0, 10), InStr(cel.Offset(0, 10), "/") - 1))
Else
tmp = Trim(cel.Offset(0, 10))
End If
.Offset(0, 5).Value = Right(tmp, Len(tmp) - InStrRev(tmp, " "))
.Offset(0, 6).Value = cel.Offset(0, 7)
End With
Next
With ws_new.Range(ws_new.Range("B2"), ws_new.Cells(ws_new.Rows.Count, "C").End(-4162).Offset(0, -1))
.FormulaR1C1 = "=IF(RC[5]>=0,""Credit"",""Debit"")"
.Value = .Value
End With
' Excel 2003 Sort
ws_new.UsedRange.Sort ws_new.Range("B2"), xlAscending, ws_new.Range("F2"), , xlAscending, ws_new.Range("C2"), xlAscending, _
xlGuess, 1, False, xlTopToBottom, xlPinYin, xlSortNormal, xlSortNormal, xlSortNormal
' Excel 2007 Sort
'ws_new.Sort.SortFields.Clear
'ws_new.Sort.SortFields.Add ws_new.Range("B:B"), xlSortOnValues, xlAscending, xlSortNormal
'ws_new.Sort.SortFields.Add ws_new.Range("F:F"), xlSortOnValues, xlAscending, xlSortNormal
'ws_new.Sort.SortFields.Add ws_new.Range("C:C"), xlSortOnValues, xlAscending, xlSortNormal
'With ws_new.Sort
' .SetRange ws_new.UsedRange
' .Header = xlYes
' .MatchCase = False
' .Orientation = xlTopToBottom
' .SortMethod = xlPinYin
' .Apply
'End With
intCreditStart = 0
intCreditEnd = 0
intDebitStart = 0
intDebitEnd = 0
For intRow = 1 To ws_new.Cells(65536, "F").End(xlUp).Row
If ws_new.Cells(intRow, 2).Value = "Debit" And intDebitStart = 0 Then intDebitStart = intRow
If ws_new.Cells(intRow, 2).Value = "Debit" Then intDebitEnd = intRow
Next
If intDebitStart > 0 Then
intEnd = intDebitEnd
For intRow = intDebitEnd To intDebitStart Step -1
If ws_new.Cells(intRow - 1, "F").Value <> ws_new.Cells(intRow, "F").Value Then
intStart = intRow
ws_new.Rows(intEnd + 1 & ":" & intEnd + 1).Insert xlDown
ws_new.Cells(intEnd + 1, "H").Formula = "=SUM(G" & intStart & ":G" & intEnd & ")"
intStart = intRow - 1
intEnd = intRow - 1
intDebitEnd = intDebitEnd + 1
End If
Next
ws_new.Cells(intDebitEnd, "I").Formula = "=SUM(G" & intDebitStart & ":G" & intDebitEnd & ")"
End If
For intRow = 1 To ws_new.Cells(65536, "F").End(xlUp).Row
If ws_new.Cells(intRow, 2).Value = "Credit" And intCreditStart = 0 Then intCreditStart = intRow
If ws_new.Cells(intRow, 2).Value = "Credit" Then intCreditEnd = intRow
Next
If intCreditStart > 0 Then
intEnd = intCreditEnd
For intRow = intCreditEnd To intCreditStart Step -1
If ws_new.Cells(intRow - 1, "F").Value <> ws_new.Cells(intRow, "F").Value Then
intStart = intRow
ws_new.Rows(intEnd + 1 & ":" & intEnd + 1).Insert xlDown
ws_new.Cells(intEnd + 1, "H").Formula = "=SUM(G" & intStart & ":G" & intEnd & ")"
intStart = intRow - 1
intEnd = intRow - 1
intCreditEnd = intCreditEnd + 1
End If
Next
ws_new.Cells(intCreditEnd, "I").Formula = "=SUM(G" & intCreditStart & ":G" & intCreditEnd & ")"
End If
ws_new.Columns("C").NumberFormat = "mm/dd/yyyy"
ws_new.Columns("F").NumberFormat = "0000000000"
ws_new.UsedRange.AutoFormat -4154 ' xlRangeAutoFormatSimple = -4154
For intRow = 2 To ws_new.Cells(65536, "H").End(xlUp).Row
If Left(ws_new.Cells(intRow, "H").Formula, 1) = "=" Then ws_new.Cells(intRow, "H").Interior.Color = 65535
If Left(ws_new.Cells(intRow, "I").Formula, 1) = "=" Then ws_new.Cells(intRow, "I").Interior.Color = 5296274
Next
ws_new.Cells.EntireColumn.AutoFit
xlApp.ScreenUpdating = True
'wb.Close False
'xlApp.Quit
'Set xlApp = Nothing
'Set wb = Nothing
Experts Exchange always has the answer, or at the least points me in the correct direction! It is like having another employee that is extremely experienced.
When asked, what has been your best career decision?
Deciding to stick with EE.
Being involved with EE helped me to grow personally and professionally.
Connect with Certified Experts to gain insight and support on specific technology challenges including:
We've partnered with two important charities to provide clean water and computer science education to those who need it most. READ MORE