Help with VBA to delimit a txt file, process data, then put it back into text

Eric M · May 30, 2014

Okay, so i'm bad at VBA, excuse the code if it's in poor form. I recorded this macro and have been editing down to what I have below. The code below works and produces what I want as far as processing the data. The problem is when I go to import it into our database the text file is not the exact same fixed-width that it was previously so is rejected by our database. Tab, comma delimitted etc. is not an option for the format of the text file.

All the code does below is delimit a fixed width text file so that Accounts in Column A, Debits in Column B and Credits in Column C. Occassionally I have negative debits or negative credits. What I need to do is if the debit is negative, move it over to the credit column and add it to the credit that is already there (if any). Same thing with negative credits.

Additionally, debits and credits start in the third row. Rows 1 and 2 have header tags in them and the very last row (which will vary day to day) has a footer in column A.

Also, I uploaded a sample of the original text file (I know debits don't equal credits, not the point just to show formatting).

Code:

Sub Fix_Neg_DR_CR()
'
' Fix_Neg_DR_CR Macro
' Fix Negative debits and credits in gl output file. Open text file in excel, run macro, save as text again. then import to meditech.
'
' Keyboard Shortcut: Ctrl+f
  Columns("A:A").Select
  Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
  FieldInfo:=Array(Array(0, 1), Array(28, 1), Array(39, 1)), TrailingMinusNumbers _
  :=True
  Range("D3").Select
  ActiveCell.FormulaR1C1 = "=IF(RC[-1]<0,-RC[-1]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"
  Range("E3").Select
  ActiveCell.FormulaR1C1 = "=IF(RC[-3]<0,-RC[-3]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"
  Range("D3:E3").Select
  Selection.AutoFill Destination:=Range("D3:E5000")
  Columns("D:E").Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Selection.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
  SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
  ReplaceFormat:=False
  Range("D2").Select
  Application.CutCopyMode = False
  ActiveCell.FormulaR1C1 = "=RC[-2]&RC[-1]"
  Columns("B:C").Select
  Range("C1").Activate
  Range("D2").Select
  Selection.Copy
  Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  Columns("B:C").Select
  Range("C1").Activate
  Application.CutCopyMode = False
  Selection.Delete Shift:=xlToLeft
End Sub

Luke M · May 30, 2014

Is the problem with your macro, or the re-import? I got a little confused.

I did take a crack at optimizing your macro, if you want.

Code:

Sub Fix_Neg_DR_CR()
'
' Fix_Neg_DR_CR Macro
' Fix Negative debits and credits in gl output file. Open text file in excel, run macro, save as text again. then import to meditech.
'
' Keyboard Shortcut: Ctrl+f

'Turn screen off for faster running
Application.ScreenUpdating = False

'Split up our data
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
   FieldInfo:=Array(Array(0, 1), Array(28, 1), Array(39, 1)), TrailingMinusNumbers _
   :=True

'Create our formulas down the entire column
Range("D3:D500").FormulaR1C1 = "=IF(RC[-1]<0,-RC[-1]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"
Range("E3:E500").FormulaR1C1 = "=IF(RC[-3]<0,-RC[-3]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"

'Change our formulas to hard values, replace 0's
With Columns("D:E")
  .Copy
  .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
      :=False, Transpose:=False
  .Replace What:="0", Replacement:="", LookAt:=xlWhole, _
      SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
      ReplaceFormat:=False
End With

'Update heading
Range("D2").Value = Range("B2").Value & Range("C2").Value

'Delete old columns
Columns("B:C").Delete Shift:=xlToLeft

'Clean up, turn screen back on
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Eric M · May 30, 2014

Sorry, let me try summarizing. I need to add a bit of code at the end of my macro to put it back into it's original fixed width text format (the one column that I had to split up at beginning of macro)...but I am not even sure where to start.

Alternatively if i could do the same thing to my data without ever splitting it up that would work too, but I don't think that would be easy with all the len(), left(), mid() formulas I would need.

Thanks for cleaning up the code though! - looks way better.

Luke M · May 30, 2014

Do you know how precise your database needs the spacing to be? Looking at even the original file, the 2nd column spacing seems odd, as the -100 doesn't line up with the 50:

The current XL output is definitely off, but nicer lined up:

PS. In the macro, change the With block to this:

Code:

'Change our formulas to hard values, replace 0's
With Columns("D:E")
    .Copy
    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
    .NumberFormat = "0.00" 'NEW LINE
End With

and that will fix the number formatting, which I just noticed.

Eric M · May 30, 2014

Okay, I actually counted the spaces. The sample file i had might have been a bit off.

The format is:

Account Column = 15 spaces Left Justified
Debit Column = 24 spaces right justified
Credit Column = 12 spaces right justified

so each line is 51 spaces.

Is there a way I can pad each column so they are fixed at that length of spaces and justified left or right?

Edit: uploaded a new file. spaces are counted out exactly as original.

Luke M · Jun 2, 2014

We can have the XL macro put spaces in. I think this is getting closer...header looks a little off.

Code:

Sub Fix_Neg_DR_CR()
'
' Fix_Neg_DR_CR Macro
' Fix Negative debits and credits in gl output file. Open text file in excel, run macro, save as text again. then import to meditech.
'
' Keyboard Shortcut: Ctrl+f

'Turn screen off for faster running
Application.ScreenUpdating = False

'Split up our data
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
   FieldInfo:=Array(Array(0, 1), Array(28, 1), Array(39, 1)), TrailingMinusNumbers _
   :=True

'Create our formulas down the entire column
Range("D3:D500").FormulaR1C1 = "=IF(RC[-1]<0,-RC[-1]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"
Range("E3:E500").FormulaR1C1 = "=IF(RC[-3]<0,-RC[-3]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"

'Change our formulas to hard values, replace 0's
With Columns("D:E")
    .Copy
    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End With

'Update heading
Range("D2").Value = Range("B2").Value & Range("C2").Value

'Delete old columns
Columns("B:C").Delete shift:=xlToLeft

'Create correct spacing
With Range("D1:D500")
    .FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,15-LEN(RC[-3])))&REPT("" "",MAX(0,24-LEN(TEXT(RC[-2],""0.00;;;@""))))&TEXT(RC[-2],""0.00;;;@"")&REPT("" "",MAX(0,12-LEN(TEXT(RC[-1],""0.00;;;@""))))&TEXT(RC[-1],""0.00;;;@"")"
    .Copy
    .PasteSpecial xlPasteValues
End With
Columns("A:C").Delete shift:=xlToLeft

'Clean up, turn screen back on
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Eric M · Jun 2, 2014

Your right, the header is a bit off. That formula is flawless on the spacing for the data though

.
One other problem, the macro seems to be cutting off the footer record.

Back to the header, it is the first 2 rows of data in every file. The spacing is as follows

Edit : Row 1: 28 spaces left justified, nothing to do really since it is not seperated in step 1 when file is delimitted.
Row 2: 10 spaces left justified, 45 spaces right justified, 3 blank spaces trailing
Rows containing data: exactly as you have it
footer: 2 spaces left justified.

Eric M · Jun 2, 2014

I took a crack at it, left a few comments where I just don't know how to do it. Mostly dealing with how to set a parameter on a data range to be the last row or the last row - 1.

Code:

'Create correct spacing
'Row 1 Spacing
With Range("D1:D1")
  .FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,28-LEN(RC[-3])))"
End With
'Row 2 Spacing
With Range("D2:D2")
  .FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,10-LEN(RC[-3])))&REPT("" "",MAX(0,45-LEN(TEXT(RC[-2],""0.00;;;@""))))&TEXT(RC[-2],""0.00;;;@"")&REPT("" "",3)"
End With
'Data Rows Spacing
With Range("D3:D500") 'Can this be changed to D3:last row less 1, could not figure how to do this
  .FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,15-LEN(RC[-3])))&REPT("" "",MAX(0,24-LEN(TEXT(RC[-2],""0.00;;;@""))))&TEXT(RC[-2],""0.00;;;@"")&REPT("" "",MAX(0,12-LEN(TEXT(RC[-1],""0.00;;;@""))))&TEXT(RC[-1],""0.00;;;@"")"
  .Copy
  .PasteSpecial xlPasteValues
End With
'Footer Rows Spacing
'define this as last row..., it is just =(RC[-3])
Columns("A:C").Delete shift:=xlToLeft

Luke M · Jun 2, 2014

I can help with finding the last row. It looks like this may be it!

Code:

Sub Fix_Neg_DR_CR()
'
' Fix_Neg_DR_CR Macro
' Fix Negative debits and credits in gl output file. Open text file in excel, run macro, save as text again. then import to meditech.
'
' Keyboard Shortcut: Ctrl+f

Dim lastRow As Long


'Turn screen off for faster running
Application.ScreenUpdating = False

'Split up our data
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
   FieldInfo:=Array(Array(0, 1), Array(28, 1), Array(39, 1)), TrailingMinusNumbers _
   :=True

'Create our formulas down the entire column
Range("D3:D500").FormulaR1C1 = "=IF(RC[-1]<0,-RC[-1]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"
Range("E3:E500").FormulaR1C1 = "=IF(RC[-3]<0,-RC[-3]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"

'Change our formulas to hard values, replace 0's
With Columns("D:E")
    .Copy
    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
    .Replace What:="0", Replacement:="", LookAt:=xlWhole, _
        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
        ReplaceFormat:=False
End With

'Update heading
Range("D2").Value = Range("B2").Value & Range("C2").Value

'Delete old columns
Columns("B:C").Delete shift:=xlToLeft

'Find last row
lastRow = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

'Create correct spacing
'Row 1
Range("D1").FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,28-LEN(RC[-3])))"

'Row 2
Range("D2").FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,10-LEN(RC[-3])))&REPT("" "",MAX(0,45-LEN(TEXT(RC[-2],""0.00;;;@""))))&TEXT(RC[-2],""0.00;;;@"")&REPT("" "",3)"

'Row 3 though lastrow - 1
Range("D3:D" & lastRow - 1).FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,15-LEN(RC[-3])))&REPT("" "",MAX(0,24-LEN(TEXT(RC[-2],""0.00;;;@""))))&TEXT(RC[-2],""0.00;;;@"")&REPT("" "",MAX(0,12-LEN(TEXT(RC[-1],""0.00;;;@""))))&TEXT(RC[-1],""0.00;;;@"")"

'Last row
Range("D" & lastRow).FormulaR1C1 = _
"=RC[-3]"

'Paste as values
With Columns("D:D")
    .Copy
    .PasteSpecial xlPasteValues
End With

Columns("A:C").Delete shift:=xlToLeft

'Clean up, turn screen back on
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Eric M · Jun 2, 2014

Just successfully imported a test file!! Thanks so much for your expertise Luke.

I have another question about this code, when you added the code to find the last row you removed the "with" ... "end with" commands I had around each section that updated the # of spaces for each range. This fixed a cell reference problem I had running the code I originally posted, do you know why? (This is just out of curiosity)

Second, my boss added more parameters to my macro -_- . I need to delete the entire row if it contains the string '48999'. Below is what I came up with. I added the variable cellDelete and at the bottom I create a helper column that is 1 if it contains 48999, else 0. It seems to do the formula right but when it deletes rows = 1 it deletes the entire selection. I tried it on samples without the string 48999 and nothing is deleted, on samples where 48999 is contained anywhere everything is deleted. Clearly I am doing something wrong with the Selection part, as it is deleting the entire defined selection. I'm not sure how to make it select a row at a time and loop for the entire range though.

Any ideas? Or should I create a new thread? Either way, your help was aweome!

Code:

Sub Fix_Neg_DR_CR()
'
' Fix_Neg_DR_CR Macro
' Fix Negative debits and credits in gl output file. Open text file in excel, run macro, save as text again. then import to meditech.
'
' Keyboard Shortcut: Ctrl+f
 
Dim lastRow As Long
Dim cellDelete As Range
'Turn screen off for faster running
Application.ScreenUpdating = False
 
'Split up our data
Columns("A:A").TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
  FieldInfo:=Array(Array(0, 1), Array(28, 1), Array(39, 1)), TrailingMinusNumbers _
  :=True
 
'Create our formulas down the entire column
Range("D3:D500").FormulaR1C1 = "=IF(RC[-1]<0,-RC[-1]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"
Range("E3:E500").FormulaR1C1 = "=IF(RC[-3]<0,-RC[-3]+RC[-2],IF(RC[-2]<0,"""",RC[-2]))"
 
'Change our formulas to hard values, replace 0's
With Columns("D:E")
  .Copy
  .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
  :=False, Transpose:=False
  .Replace What:="0", Replacement:="", LookAt:=xlWhole, _
  SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
  ReplaceFormat:=False
End With
 
'Update heading
Range("D2").Value = Range("B2").Value & Range("C2").Value
 
'Delete old columns
Columns("B:C").Delete shift:=xlToLeft
 
'Find last row
lastRow = Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row
 
'Create correct spacing
'Row 1
Range("D1").FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,28-LEN(RC[-3])))"
 
'Row 2
Range("D2").FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,10-LEN(RC[-3])))&REPT("" "",MAX(0,45-LEN(TEXT(RC[-2],""0.00;;;@""))))&TEXT(RC[-2],""0.00;;;@"")&REPT("" "",3)"
 
'Row 3 though lastrow - 1
Range("D3:D" & lastRow - 1).FormulaR1C1 = _
"=RC[-3]&REPT("" "",MAX(0,15-LEN(RC[-3])))&REPT("" "",MAX(0,24-LEN(TEXT(RC[-2],""0.00;;;@""))))&TEXT(RC[-2],""0.00;;;@"")&REPT("" "",MAX(0,12-LEN(TEXT(RC[-1],""0.00;;;@""))))&TEXT(RC[-1],""0.00;;;@"")"
 
'Last row
Range("D" & lastRow).FormulaR1C1 = _
"=RC[-3]"
 
'Paste as values
With Columns("D:D")
  .Copy
  .PasteSpecial xlPasteValues
End With
 
Columns("A:C").Delete shift:=xlToLeft
'Delete entire Row if it contains the string "48999"
Range("B1:B" & lastRow).FormulaR1C1 = _
"=IF(IFERROR(SEARCH(48999,RC[-1],1),0)<>0,1,0)"
Set cellDelete = Range("B1:B" & lastRow)
cellDelete.Select
For Each cellDelete In Selection
If cellDelete = 1 Then
Selection.EntireRow.Delete
End If
Next
Columns("B:B").Delete
'Clean up, turn screen back on
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub

Luke M · Jun 2, 2014

To answer your first question, I removed the With statements since instead of doing several things (create formula, copy, paste) we were doing only one operation, so it wasn't saving us any calc time. It also just makes it a little easier to read, IMO.

To get rid of all the strings, instead of using a formula and stepping down, we'll use the Find method. After the line about Deleting columns A:C, replace the section of code you wrote with this:

Code:

'This would be near the top, where we define the other variable(s)
Dim fCell As Range

With Range("A:A")
    Set fCell = .Find(what:="48999", lookat:=xlPart)
   
    'Keep looping through and deleting rows
    Do Until fCell Is Nothing
        fCell.EntireRow.Delete shift:=xlShiftUp
        Set fCell = .Find(what:="test", lookat:=xlPart)
    Loop
End With

Eric M · Jun 2, 2014

Ok, does the find function rely on them being ordered? When I run it, it deletes the first instance and I think when the very next value does not contain 48999 it stops, even though there are other strings containing 48999 after that.

Luke M · Jun 2, 2014

DOH! I forgot to change the line after I was done testing. This line:

Code:

Set fCell = .Find(what:="test", lookat:=xlPart)

Should not refer to "test".

change it it:

Code:

Set fCell = .Find(what:="48999", lookat:=xlPart)

and you should be back in business.

Eric M · Jun 2, 2014

I'm back in business

Thanks a lot! Post is solved

Help with VBA to delimit a txt file, process data, then put it back into text

Eric M

Member

Attachments

Luke M

Excel Ninja

Eric M

Member

Luke M

Excel Ninja

Eric M

Member

Attachments

Luke M

Excel Ninja

Eric M

Member

Eric M

Member

Luke M

Excel Ninja

Eric M

Member

Luke M

Excel Ninja

Eric M

Member

Luke M

Excel Ninja

Eric M

Member