File01.txt

Solved

Posted on 2012-08-25

Hello,

I've been using below macro for a while, but I need to adjust a bit.

Based on Column "A", IF cell is Empty:

- coy value for Empty cells in Column "A" from cell in previous Row.

- Replace Column "O" with "RMA"

- fill Column "S" with "0.01"

Option Explicit

Public Sub ImportAndSplitDeliveryANDReturnCombined()

Dim wkb As Workbook

Dim rngSrc As Range

Dim rngCell As Range

Dim rngTgt As Range

Dim rngUsed As Range

Dim strPath As String

Application.ScreenUpdating = False

'Open the file as fixed length data

Workbooks.OpenText Filename:="C:\Users\user.DOMAIN\Desktop\File01.out", Origin:=437, _

StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _

Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _

Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _

Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _

Array(466, 1)), TrailingMinusNumbers:=True

strPath = ActiveWorkbook.Path

Set rngUsed = ActiveSheet.Range([A1], ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))

'Trim column I

For Each rngCell In rngUsed.Columns(9).Cells

rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)

Next

'Zero out the time component of the date/time value in column Q

For Each rngCell In rngUsed.Columns(17).Cells

rngCell.Value = Left(rngCell.Value, 12) & ""

Next

Set wkb = ActiveWorkbook

wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges

wkb.Close False

Application.ScreenUpdating = True

End Sub

Any help is appreciated.

I've been using below macro for a while, but I need to adjust a bit.

Based on Column "A", IF cell is Empty:

- coy value for Empty cells in Column "A" from cell in previous Row.

- Replace Column "O" with "RMA"

- fill Column "S" with "0.01"

Option Explicit

Public Sub ImportAndSplitDeliveryANDR

Dim wkb As Workbook

Dim rngSrc As Range

Dim rngCell As Range

Dim rngTgt As Range

Dim rngUsed As Range

Dim strPath As String

Application.ScreenUpdating

'Open the file as fixed length data

Workbooks.OpenText Filename:="C:\Users\user.D

StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _

Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _

Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _

Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _

Array(466, 1)), TrailingMinusNumbers:=True

strPath = ActiveWorkbook.Path

Set rngUsed = ActiveSheet.Range([A1], ActiveSheet.Cells.SpecialC

'Trim column I

For Each rngCell In rngUsed.Columns(9).Cells

rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)

Next

'Zero out the time component of the date/time value in column Q

For Each rngCell In rngUsed.Columns(17).Cells

rngCell.Value = Left(rngCell.Value, 12) & ""

Next

Set wkb = ActiveWorkbook

wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges

wkb.Close False

Application.ScreenUpdating

End Sub

Any help is appreciated.

15 Comments

Please see sample attached (I changed the extension from .out to .txt)

File01.txt

File01.txt

Column "A" ,all cells have the same value. (DATE)

So empty cells in Column "A" can have the same value of any other cell in the same Column "A".

```
Option Explicit
Public Sub ImportAndSplitDeliveryANDReturnCombined()
Dim wkb As Workbook
Dim wks As Worksheet
Dim rngSrc As Range
Dim rngCell As Range
Dim rngTgt As Range
Dim rngUsed As Range
Dim strPath As String
Dim strDate As String
Application.ScreenUpdating = False
'Open the file as fixed length data
Workbooks.OpenText Filename:="C:\Users\user.DOMAIN\Desktop\File01.out", Origin:=437, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _
Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _
Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _
Array(466, 1)), TrailingMinusNumbers:=True
Set wkb = ActiveWorkbook
strPath = wkb.Path
Set wks = wkb.ActiveSheet
Set rngUsed = wks.Range([A1], ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
'Trim column I
For Each rngCell In rngUsed.Columns(9).Cells
rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)
Next rngCell
'Zero out the time component of the date/time value in column Q
For Each rngCell In rngUsed.Columns(17).Cells
rngCell.Value = Left(rngCell.Value, 12) & ""
Next rngCell
' find a non-blank value in col A (simplest to look for the last)
Set rngCell = wks.Cells(wks.Rows.Count, rngUsed.Column).End(xlUp)
' if we found a cell with a value, use it; otherwise use today's date
strDate = Trim$(rngCell.Value)
If Len(strDate) = 0 Then
strDate = Format(Int(Now), "yyyymmdd")
End If
rngUsed.Columns(1).Cells.Value = strDate
' Fill column O
rngUsed.Columns(15).Cells.Value = "RMA"
' Fill column S
rngUsed.Columns(19).Cells.Value = 0.01
wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
wkb.Close False
Application.ScreenUpdating = True
End Sub
```

2 small issues,

' Fill column O

rngUsed.Columns(15).Cells.

' Fill column S

rngUsed.Columns(19).Cells.

this should only apply if cell in Column "A" was blank.

thanks

```
Public Sub ImportAndSplitDeliveryANDReturnCombined()
Dim wkb As Workbook
Dim wks As Worksheet
Dim rngSrc As Range
Dim rngCell As Range
Dim rngTgt As Range
Dim rngUsed As Range
Dim strPath As String
Dim strDate As String
Application.ScreenUpdating = False
'Open the file as fixed length data
Workbooks.OpenText Filename:="C:\Users\stuart\Desktop\File01.out", Origin:=437, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _
Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _
Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _
Array(466, 1)), TrailingMinusNumbers:=True
Set wkb = ActiveWorkbook
strPath = wkb.Path
Set wks = wkb.ActiveSheet
Set rngUsed = wks.Range([A1], ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
'Trim column I
For Each rngCell In rngUsed.Columns(9).Cells
rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)
Next rngCell
'Zero out the time component of the date/time value in column Q
For Each rngCell In rngUsed.Columns(17).Cells
rngCell.Value = Left(rngCell.Value, 12) & ""
Next rngCell
' find a non-blank value in col A (simplest to look for the last)
Set rngCell = wks.Cells(wks.Rows.Count, rngUsed.Column).End(xlUp)
' if we found a cell with a value, use it; otherwise use today's date
strDate = Trim$(rngCell.Value)
If Len(strDate) = 0 Then
strDate = Format(Int(Now), "yyyymmdd")
End If
For Each rngCell In rngUsed.Columns(1).Cells
If Len(Trim$(rngCell.Value)) = 0 Then
rngCell.Value = strDate
' Fill column O
rngCell.Offset(0, 14).Value = "RMA"
' Fill column S
rngCell.Offset(0, 18).Value = 0.01
End If
Next rngCell
' wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
' wkb.Close False
Application.ScreenUpdating = True
End Sub
```

Sorry to be a pain,

but,

' Fill column O

rngUsed.Columns(15).Cells.

on the original out file, it has a plus sign (+RMA), if you can remove the + sign, then probelm solved and it will be RMA after I run the code..

Thanks,

I could remove the + from any string in that column.

if you can do this, this will solve future issues I might encounter.

I will increase the points to 500.

Are you able to split the output files based on Column "O"

example:

Column "O" -- RG .. output file will be File01

Column "O" -- RMA .. output file will be File02

Thanks.

```
Public Sub ImportAndSplitDeliveryANDReturnCombined()
Dim wkb As Workbook
Dim wks As Worksheet
Dim rngSrc As Range
Dim rngCell As Range
Dim rngTgt As Range
Dim rngUsed As Range
Dim strPath As String
Dim strDate As String
Dim strTemp As String
Dim aOut As Variant
Dim aOut1 As Variant
Dim aOut2 As Variant
Dim lngOutRow As Long
Dim lngOut1Row As Long
Dim lngOut2Row As Long
Dim j As Long
Application.ScreenUpdating = False
'Open the file as fixed length data
Workbooks.OpenText Filename:="C:\Users\stuart\Desktop\File01.out", Origin:=437, _
StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), _
Array(8, 1), Array(14, 2), Array(29, 1), Array(39, 1), Array(55, 1), Array(63, 1), _
Array(163, 1), Array(213, 1), Array(263, 1), Array(307, 1), Array(353, 1), Array(393, 1), _
Array(403, 1), Array(418, 1), Array(422, 2), Array(439, 2), Array(451, 2), _
Array(466, 1)), TrailingMinusNumbers:=True
Set wkb = ActiveWorkbook
strPath = wkb.Path
Set wks = wkb.ActiveSheet
Set rngUsed = wks.Range([A1], ActiveSheet.Cells.SpecialCells(xlCellTypeLastCell))
'Trim column I
For Each rngCell In rngUsed.Columns(9).Cells
rngCell.Value = Left(rngCell.Value, Len(rngCell.Value) - 3)
Next rngCell
'Zero out the time component of the date/time value in column Q
For Each rngCell In rngUsed.Columns(17).Cells
rngCell.Value = Left(rngCell.Value, 12) & ""
Next rngCell
' find a non-blank value in col A (simplest to look for the last)
Set rngCell = wks.Cells(wks.Rows.Count, rngUsed.Column).End(xlUp)
' if we found a cell with a value, use it; otherwise use today's date
strDate = Trim$(rngCell.Value)
If Len(strDate) = 0 Then
strDate = Format(Int(Now), "yyyymmdd")
End If
For Each rngCell In rngUsed.Columns(1).Cells
If Len(Trim$(rngCell.Value)) = 0 Then
rngCell.Value = strDate
' Fill column O
rngCell.Offset(0, 14).Value = "RMA"
' Fill column S
rngCell.Offset(0, 18).Value = 0.01
End If
Next rngCell
' remove a + sign from the start of column O if present
For Each rngCell In rngUsed.Columns(15).Cells
strTemp = rngCell.Value
If Left(strTemp, 1) = "+" Then
rngCell.Value = Mid(strTemp, 2)
End If
Next rngCell
' now split the file into two depending on the value of column O
aOut = rngUsed.Value
' define temp arrays for each one - make each big enoug to hold the maximum
ReDim aOut1(1 To UBound(aOut, 1), 1 To UBound(aOut, 2))
ReDim aOut2(1 To UBound(aOut, 1), 1 To UBound(aOut, 2))
lngOut1Row = 1
lngOut2Row = 1
For lngOutRow = 1 To UBound(aOut, 1)
Select Case aOut(lngOutRow, 15)
Case "RG"
' take all columns to the first output array
For j = 1 To UBound(aOut, 2)
aOut1(lngOut1Row, j) = "'" & aOut(lngOutRow, j)
Next j
lngOut1Row = lngOut1Row + 1
Case "RMA"
' take all columns to the second output array
For j = 1 To UBound(aOut, 2)
aOut2(lngOut2Row, j) = "'" & aOut(lngOutRow, j)
Next j
lngOut2Row = lngOut2Row + 1
Case Else
' can there be other values?
End Select
Next lngOutRow
' finished with the main range - clear it
rngUsed.EntireRow.Delete
' write the first output if any rows found
If lngOut1Row > 1 Then
wks.Cells(1).Resize(lngOut1Row - 1, UBound(aOut, 2)).Value = aOut1
wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
End If
wks.UsedRange.EntireRow.Delete
' write the second output if any rows found
If lngOut2Row > 1 Then
wks.Cells(1).Resize(lngOut2Row - 1, UBound(aOut, 2)).Value = aOut2
wkb.SaveAs strPath & "\Combined02", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
End If
' wkb.SaveAs strPath & "\Combined01", XlFileFormat.xlCSV, , , , , , xlLocalSessionChanges
wkb.Close False
Application.ScreenUpdating = True
End Sub
```

thank you for your time,

I should have said that RG and RMA are not the only 2 codes in Column "O".

The out put files, should be:

RMA is one outputfile

All other codes in Column "O" is the other output file.

what's happening now is,

if Date in Column "A" --- then it is changing Column "O" to RG

if NO Date in Column "A" --- then it is changing Column "O" to RMA

Can you please help.

thanks.

By clicking you are agreeing to Experts Exchange's Terms of Use.

Title | # Comments | Views | Activity |
---|---|---|---|

Vlookup for IP | 3 | 33 | |

make top menus bigger font | 3 | 25 | |

Can you create a VBA macro that checks if folder exists and if not creates one | 9 | 42 | |

Ensuring all processes are complete before continuing | 6 | 13 |

Join the community of 500,000 technology professionals and ask your questions.

Connect with top rated Experts

**22** Experts available now in Live!