We help IT Professionals succeed at work.

Get rid of characters from the cells

adamssap
adamssap asked
on
Hi:

I have an excel file and I have a VBScript to sort, add columns and do calculations. The script is working fine (as desired) but some how the new excel file has <BR> tag in some of the cells.

Is it possible to get rid of the '<BR>' tags from any cell in the whole file? dfile.csv
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

Open in new window

Comment
Watch Question

View Solution Only

ScriptAddict
CERTIFIED EXPERT

Commented:
Find <BR>
and replace with ""

or something incorporating:
Sub FormulaFindAndReplace(phrase As String) 
  For Each Sheet_Select In ActiveWorkbook.Worksheets 
    Sheet_Select.Activate 
    Set Found_Link = Cells.Find(what:=phrase, After:=ActiveCell, _ 
        LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByRows, _ 
        searchdirection:=xlNext, MatchCase:=False) 
    While UCase(TypeName(Found_Link)) <> UCase("Nothing") 
       Found_Link.Activate 
       Found_Link.Formula = Replace(Found_Link.Formula, phrase, "") 
       Set Found_Link = Cells.FindNext(After:=ActiveCell) 
    Wend 
  Next Sheet_Select 
End Sub

Open in new window

ScriptAddict
CERTIFIED EXPERT

Commented:
Add the above code and then adjust your original code like this

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

FormulaFindAndReplace("<BR>")
    
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

Open in new window

adamssap

Author

Commented:
Where should I add the Sub in the script?

Do I need to call it?

Thanks.
ScriptAddict
CERTIFIED EXPERT

Commented:
The way to call it is to add it to your script after the <BR> is created.  I've included the line to insert.  

ws_new.Cells.EntireColumn.AutoFit

FormulaFindAndReplace("<BR>")

xlApp.ScreenUpdating = True
'wb.Close False
'xlApp.Quit
'Set xlApp = Nothing
'Set wb = Nothing 
Toggle HighlightingOpen in New Window

Open in new window


Will likely do the trick
adamssap

Author

Commented:
I am getting an error in line 22, attached is the complete code.
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

ws_new.Cells.EntireColumn.AutoFit

FormulaFindAndReplace("<BR>")

xlApp.ScreenUpdating = True
'wb.Close False
'xlApp.Quit
'Set xlApp = Nothing
'Set wb = Nothing 
    
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

Open in new window

ScriptAddict
CERTIFIED EXPERT

Commented:
Did you already add the sub code?

Sub FormulaFindAndReplace(phrase As String) 
  For Each Sheet_Select In ActiveWorkbook.Worksheets 
    Sheet_Select.Activate 
    Set Found_Link = Cells.Find(what:=phrase, After:=ActiveCell, _ 
        LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByRows, _ 
        searchdirection:=xlNext, MatchCase:=False) 
    While UCase(TypeName(Found_Link)) <> UCase("Nothing") 
       Found_Link.Activate 
       Found_Link.Formula = Replace(Found_Link.Formula, phrase, "") 
       Set Found_Link = Cells.FindNext(After:=ActiveCell) 
    Wend 
  Next Sheet_Select 
End Sub

Open in new window

ScriptAddict
CERTIFIED EXPERT

Commented:
Just plug that in  after the end sub on the other code.
adamssap

Author

Commented:
I added the sub and here is the complete code. I get error on line 24 now.
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

ws_new.Cells.EntireColumn.AutoFit

Sub FormulaFindAndReplace(phrase As String) 
  For Each Sheet_Select In ActiveWorkbook.Worksheets 
    Sheet_Select.Activate 
    Set Found_Link = Cells.Find(what:=phrase, After:=ActiveCell, _ 
        LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByRows, _ 
        searchdirection:=xlNext, MatchCase:=False) 
    While UCase(TypeName(Found_Link)) <> UCase("Nothing") 
       Found_Link.Activate 
       Found_Link.Formula = Replace(Found_Link.Formula, phrase, "") 
       Set Found_Link = Cells.FindNext(After:=ActiveCell) 
    Wend 
  Next Sheet_Select 
End Sub 

FormulaFindAndReplace("<BR>")

xlApp.ScreenUpdating = True
'wb.Close False
'xlApp.Quit
'Set xlApp = Nothing
'Set wb = Nothing 
    
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

Open in new window

ScriptAddict
CERTIFIED EXPERT

Commented:
I'm sorry I wasn't clear.  I'm sure that after line 158 you must have something that says end sub right before the line

You want to add the function code there.  

Please remove lines 24-36 and add them after the end of the code.  so beyond line 158.
adamssap

Author

Commented:
Now the error is on line 147.
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

ws_new.Cells.EntireColumn.AutoFit


FormulaFindAndReplace("<BR>")

xlApp.ScreenUpdating = True
'wb.Close False
'xlApp.Quit
'Set xlApp = Nothing
'Set wb = Nothing 
    
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

Sub FormulaFindAndReplace(phrase As String) 
  For Each Sheet_Select In ActiveWorkbook.Worksheets 
    Sheet_Select.Activate 
    Set Found_Link = Cells.Find(what:=phrase, After:=ActiveCell, _ 
        LookIn:=xlFormulas, lookat:=xlPart, searchorder:=xlByRows, _ 
        searchdirection:=xlNext, MatchCase:=False) 
    While UCase(TypeName(Found_Link)) <> UCase("Nothing") 
       Found_Link.Activate 
       Found_Link.Formula = Replace(Found_Link.Formula, phrase, "") 
       Set Found_Link = Cells.FindNext(After:=ActiveCell) 
    Wend 
  Next Sheet_Select 
End Sub

Open in new window

ScriptAddict
CERTIFIED EXPERT

Commented:
Your not posting all of the code.  There must be something after line 159.  

If there is NOTHING beyond line 159 then just put a

end sub on line 146.

adamssap

Author

Commented:
I am sorry but this is the complete code.  If there is no Sub, why should I add End Sub after line 146.  Error is on line 147.  Is it working on your computer?

Thanks for your help.
ScriptAddict
CERTIFIED EXPERT

Commented:
Sorry I've been doing VBA for Excel almost exclusively here.  You've got to admit they look very similar.

This should work for you

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
	If InStr(cel.Offset(0, 10), "<BR>") > 0 Then
        	tmp = Trim(Left(cel.Offset(0, 10), InStr(cel.Offset(0, 10), "<BR>") - 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

Open in new window

adamssap

Author

Commented:
Thanks, that works good, but data in the resulting sheet on the column 'Account' must be the last number .

eg 1:
MERCHANT SERVICE MERCH DEP 111012 <BR>17789000052801
then the account is 17789000052801
eg. 2:
MERCHANT SERVICE MERCH DEP 111012 17789000052801
then account is 17789000052801

But now the script is adding 111012 to the Account column.

Thanks again for your help.
ScriptAddict
CERTIFIED EXPERT

Commented:
This should fix it.

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

 	If InStr(tmp, "<BR>") > 0 Then
        	tmp = Trim(Left(tmp, InStr(tmp, "<BR>") - 4))
        Else
        	tmp = Trim(tmp)
        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

Open in new window

adamssap

Author

Commented:
Not really, maybe I am not clear.  Account is right most number.

for example: MERCHANT SERVICE MERCH DEP 111012 <BR>17789000052801

Here the Account is 17789000052801 and not 111012

adamssap

Author

Commented:
I just found out that the script is giving wrong account for some row only.  Please see attached file
 dfile.CSV
adamssap

Author

Commented:
Please ignore previous message.  The script is giving wrong account only when it has the '<BR>' tag.  See attached screenshot screen
CERTIFIED EXPERT
Commented:
Hmmm, thought I had already fixed that.  This is testing correct on my system.

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 = replace(Trim(Left(cel.Offset(0, 10), InStr(cel.Offset(0, 10), "/") - 1)),"<BR>","")
        Else
        	tmp = Trim(replace(cel.Offset(0, 10),"<BR>",""))
        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

Open in new window

Explore More ContentExplore courses, solutions, and other research materials related to this topic.