Hi all,
First post so please be gentle.
I'm fairly new to VBA and up until now I've been able to get by by searching the internet and adapting the bits of code I find to fit my needs.
I need to create a Macro that exports data from a spreadsheet into a fixed width format file. I changed the example I tracked down on the web to deal with non-contiguous data and with early testing it seemed to work ok.
However, adding additional data has broken the export.
I've attached the relevant code and the full spreadsheet (the extract file I've had to leave as I can only upload 1 file).
Any help as to where I've gone wrong, or an alternative method of identifying the blocks of data will be gratefully received.
Thanks in advance.
[vba]Sub Export_Selection_As_Fixed_Length_File()
' Dimension all variables.
Dim DestinationFile, CellValue, Filler_Char_To_Replace_Blanks As String
Dim FileNum, ColumnCount, RowCount, FieldWidth As Integer
Dim sht As Worksheet
'Below are options incase you want to change the folder where VBA stores the .txt file
'We use ActiveWorkbook.Path in this example
'ActiveWorkbook.Path 'the activeworkbook
'ThisWorkbook.Path 'the workbook with the code
'CurDir 'the current directory (when you hit File|open)
'If a cell is blank, what character should be used instead
Filler_Char_To_Replace_Blanks = " "
' This is the destination file name.
GetQuoteNumber
GetSheetNumber
DestinationFile = ActiveWorkbook.Path & "/" & QuoteNumber & "-000" & SheetNumber & ".txt"
' Obtain next free file handle number.
FileNum = FreeFile()
' Turn error checking off.
On Error Resume Next
' Attempt to open destination file for output.
Open DestinationFile For Output As #FileNum
' If an error occurs report it and end.
If Err <> 0 Then
MsgBox "Cannot open filename " & DestinationFile
Selection.Activate
End
End If
'here I need to programmatically select cells
'these should be top left to bottom right of used cells
'Range("A3:H3").Select
Dim StartCell, EndCell, TestCell, StartTestCell, EndTestCell, CompleteFlag, FoundStartRow
CompleteFlag = "No"
StartCell = "A"
StartTestCellRow = "2"
EndTestCellRow = "500"
MsgBox ("Limited to: " & "AD" & StartTestCellRow & ":AD" & EndTestCellRow & "")
' - - - - - - - Main loop = Find block of data by testing column 30 for next Y
While CompleteFlag = "No" ' Loop until an empty cell is found in Column: AD
FoundStartRow = "No" ' Inner loop to find next "Y" after a block detected/exported
' MsgBox ("Start Row = " & StartTestCellRow)
For Each TestCell In Worksheets("Export as Fixed Length File").Range("AD" & StartTestCellRow & ":AD" & EndTestCellRow & "")
TestCell.Select
If IsEmpty(TestCell.Value) Then ' Stop when there is no more data in the range limit provided
CompleteFlag = "Yes"
Exit For
End If
If TestCell.Value = "N" Then ' Keep testing cells in Column AD, ignore line where its N (for No export)
If FoundStartRow <> "No" Then
LastRowUsed = TestCell.Row - 1
Exit For
End If
Else
If FoundStartRow = "No" Then ' If we are in the process of locating a new block, here it is!
FoundStartRow = "Yes"
StartCell = "A" & TestCell.Row
End If
End If
Next TestCell
StartTestCellRow = LastRowUsed + 1
' Dim TheLastRow As Long
' TheLastRow = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
' MsgBox (TheLastRow)
' FindLastRowUsed <-- cannot use this because it only deal with the WHOLE sheet
EndCell = "AC" & LastRowUsed & ""
Range("" & StartCell & ":" & EndCell & "").Select
' Check if the user has made any selection at all
If Selection.Cells.Count < 2 Then
MsgBox "Nothing selected to export"
Selection.Activate
End
End If
' Turn error checking on.
On Error GoTo 0
' Loop for each row in selection.
For RowCount = 1 To Selection.Rows.Count
For ColumnCount = 1 To Selection.Columns.Count
CellValue = Selection.Cells(RowCount, ColumnCount).Text
If (IsNull(CellValue) Or CellValue = "") Then CellValue = Filler_Char_To_Replace_Blanks
FieldWidth = Cells(1, ColumnCount).Value
If (ColumnCount = Selection.Columns.Count) Then
Print #FileNum, Format$(CellValue, "!" & String(FieldWidth, "@")) & vbCrLf;
Else: Print #FileNum, Format$(CellValue, "!" & String(FieldWidth, "@"));
End If
Next ColumnCount
' Start next iteration of RowCount loop.
Next RowCount
Wend
' - - - - - - - End of Main loop
' Close destination file.
Close #FileNum
' Selection.Activate
' Range("A1").Select
' Workbooks.OpenText Filename:=DestinationFile
End Sub[/vba]
Paul.
Reply With Quote