I am trying create a macro that will bring up a dialog box to open an excel file, then run it through a file cleanup, then after cleanup automatically save it to a different directory with the same name but as a fixed text file. What I have brings a dialog box up to export and I have to type in the filename and switch directories. Can anyone help me???
Here is what I have now:
Option Explicit
Function WriteFile(delimiter As String, quotes As Integer) As String
' Dimension variables to be used in this function.
Dim CurFile As String
Dim SaveFileName
Dim CellText As String
Dim RowNum As Integer
Dim ColNum As Integer
Dim FNum As Integer
Dim TotalRows As Double
Dim TotalCols As Double
ChDir "C:\Documents and Settings\jrick\Desktop\Test 2"
' Show Save As dialog box with the .TXT file name as the default.
' Test to see what kind of system this macro is being run on.
If Left(Application.OperatingSystem, 3) = "Win" Then
SaveFileName = Application.GetSaveAsFilename(CurFile, _
"Text Delimited (*.txt), *.txt", , "Text Delimited Exporter")
Else
SaveFileName = Application.GetSaveAsFilename(CurFile, _
"TEXT", , "Text Delimited Exporter")
End If
' Check to see if Cancel was clicked.
If SaveFileName = False Then
WriteFile = "Canceled"
Exit Function
End If
' Obtain the next free file number.
FNum = FreeFile()
' Open the selected file name for data output.
Open SaveFileName For Output As #FNum
' Store the total number of rows and columns to variables.
TotalRows = Selection.Rows.Count
TotalCols = Selection.Columns.Count
' Loop through every cell, from left to right and top to bottom.
For RowNum = 1 To TotalRows
For ColNum = 1 To TotalCols
With Selection.Cells(RowNum, ColNum)
Dim ColWidth As Integer
ColWidth = Application.RoundUp(.ColumnWidth, 0)
' Store the current cells contents to a variable.
Select Case .HorizontalAlignment
Case xlRight
CellText = Space(ColWidth - Len(.Text)) & .Text
Case xlCenter
CellText = Space((ColWidth - Len(.Text)) / 2) & .Text & _
Space((ColWidth - Len(.Text)) / 2)
Case Else
CellText = .Text & Space(ColWidth - Len(.Text))
Debug.Print
End Select
End With
' Write the contents to the file.
' With or without quotation marks around the cell information.
'Select Case quotes
'Case vbYes
'CellText = Chr(34) & CellText & Chr(34) & delimiter
'Case vbNo
CellText = CellText & delimiter
'End Select
Print #FNum, CellText;
' Update the status bar with the progress.
Application.StatusBar = Format((((RowNum - 1) * TotalCols) _
+ ColNum) / (TotalRows * TotalCols), "0%") & " Completed."
' Loop to the next column.
Next ColNum
' Add a linefeed character at the end of each row.
If RowNum <> TotalRows Then Print #FNum, ""
' Loop to the next row.
Next RowNum
' Close the .prn file.
Close #FNum
' Reset the status bar.
Application.StatusBar = False
WriteFile = "Exported"
End Function
Sub LoadListCleanup()
' Loadlist Macro
' Keyboard Shortcut: Ctrl+t
' Prompts User to Choose a File to Open at C:\
' -- Begin Open and Import File
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim myFile As String
Dim rnge As Excel.Range 'Column E formatting
Dim rngOP As Excel.Range 'Columns O-P formatting
Dim rngAD As Excel.Range 'Column AD formatting
Dim rngA As Excel.Range 'Test for header row
Dim x As Variant 'Counter for keycode errors
Dim y As Variant 'Counter for country code
Dim rngWhole As Excel.Range 'Selects relevant range for writing a text file
Dim rngCol As Variant
Dim a As Variant
Dim rngLen As Variant 'variable for determining range size
rngCol = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", "N", "O", "P", "Q", _
"R", "S", "T", "U", "V", "W", "X", "Y", "Z", "AA", "AB", "AC", "AD", _
"AE", "AF", "AG", "AH", "AI", "AJ", "AK", "AL", "AM", "AN")
ChDir "C:\Documents and Settings\jrick\Desktop\Test 1"
myFile = Application.GetOpenFilename("All Files,*.*")
Workbooks.OpenText Filename:=myFile, _
Origin:=xlWindows, _
StartRow:=1, _
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, _
Comma:=True, _
Space:=False, _
Other:=False, _
FieldInfo:=Array(Array(1, 1), Array(2, 1), Array( _
3, 1), Array(4, 1), Array(5, 1), Array(6, 1), Array(7, 1), Array(8, 1), Array(9, 1), Array(10 _
, 1), Array(11, 1), Array(12, 1), Array(13, 1), Array(14, 1), Array(15, 1), Array(16, 1), _
Array(17, 1), Array(18, 1), Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1), Array( _
23, 1), Array(24, 1), Array(25, 1), Array(26, 1), Array(27, 1), Array(28, 1), Array(29, 1), _
Array(30, 1), Array(31, 1))
' Check for headers and deletes them if they're there
'Cleanup File Begin
Set rnge = Columns("E:E")
rnge.Replace What:="MR ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
rnge.Replace What:="MS ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Set rngOP = Columns("O:P")
rngOP.Replace What:="/", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
rngOP.Replace What:="-", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
rngOP.Replace What:="(", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
rngOP.Replace What:=")", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
rngOP.Replace What:=" ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
Set rngAD = Columns("AD:AD")
rngAD.Replace What:="BJ", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False
' Cleanup File End
Set rngA = Range("A1")
If rngA <> "" Then
rngA.EntireRow.Delete
End If
Range("AN1").Select
x = 0
Do
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value = "" Then
x = x + 1
End If
Loop Until ActiveCell.Offset(1, -28) = "" 'Assuming here all records have a zip code
If x > 1 Then
MsgBox "There are " & x & " empty KEYCODE fields. Please check the data before uploading the file to Multi-Pub."
End If
Range("M1").Select
y = 0
Do
ActiveCell.Offset(1, 0).Select
If ActiveCell.Value <> "" Then
y = y + 1
End If
Loop Until ActiveCell.Offset(1, -1) = "" 'Assuming here all records have a zip code
If y > 1 Then
MsgBox "There are " & y & " populated COUNTRY CODE fields. Please check the data before uploading the file to Multi-Pub."
End If
If x > 0 Or y > 0 Then
MsgBox "Please correct the errors and run the program again. No changes have been saved."
ActiveWorkbook.Close False
Exit Sub
End If
With Cells.Font
.Name = "Courier New"
.Size = 8
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
End With
Cells.EntireColumn.AutoFit
Columns("O:O").NumberFormat = "0"
Columns("A:A").ColumnWidth = 8
Columns("B:B").ColumnWidth = 30
Columns("C:C").ColumnWidth = 30
Columns("D:D").ColumnWidth = 1
Columns("E:E").ColumnWidth = 20
Columns("F:F").ColumnWidth = 30
Columns("G:G").ColumnWidth = 30
Columns("H:H").ColumnWidth = 30
Columns("I:I").ColumnWidth = 30
Columns("J:J").ColumnWidth = 30
Columns("K:K").ColumnWidth = 2
Columns("L:L").ColumnWidth = 10
Columns("M:M").ColumnWidth = 30
Columns("N:N").ColumnWidth = 4
Columns("O:O").ColumnWidth = 16
Columns("P:P").ColumnWidth = 16
Columns("Q:Q").ColumnWidth = 8
Columns("R:R").ColumnWidth = 6
Columns("S:S").ColumnWidth = 5
Columns("T:T").ColumnWidth = 6
Columns("U:U").ColumnWidth = 5
Columns("V:V").ColumnWidth = 8
Columns("W:W").ColumnWidth = 6
Columns("X:X").ColumnWidth = 30
Columns("Y:Y").ColumnWidth = 3
Columns("Z:Z").ColumnWidth = 8
Columns("AA:AA").ColumnWidth = 8
Columns("AB:AB").ColumnWidth = 8
Columns("AC:AC").ColumnWidth = 8
Columns("AD:AD").ColumnWidth = 8
Columns("AE:AE").ColumnWidth = 8
Columns("AF:AF").ColumnWidth = 2
Columns("AG:AG").ColumnWidth = 3
Columns("AH:AH").ColumnWidth = 7
Columns("AI:AI").ColumnWidth = 50
Columns("AJ:AJ").ColumnWidth = 16
Columns("AK:AK").ColumnWidth = 7
Columns("AL:AL").ColumnWidth = 50
Columns("AM:AM").ColumnWidth = 4
Columns("AN:AN").ColumnWidth = 11
'Trims down the character lengths for the export to a text file
Set rngLen = Range(Range("AN1"), Range("AN1").End(xlDown))
For a = 2 To UBound(rngCol)
Columns(rngCol(a) & ":" & rngCol(a)).Insert Shift:=xlToRight
Select Case Range(rngCol(a - 1) & ":" & rngCol(a - 1)).ColumnWidth
Case Is = 30
Range(rngCol(a) & "1").FormulaR1C1 = "=IF(LEN(RC[-1])>30,LEFT(RC[-1],30),RC[-1])"
Case Is = 20
Range(rngCol(a) & "1").FormulaR1C1 = "=IF(LEN(RC[-1])>20,LEFT(RC[-1],20),RC[-1])"
Case Is = 50
Range(rngCol(a) & "1").FormulaR1C1 = "=IF(LEN(RC[-1])>50,LEFT(RC[-1],50),RC[-1])"
Case Is = 16
Range(rngCol(a) & "1").FormulaR1C1 = "=IF(LEN(RC[-1])>16,LEFT(RC[-1],16),RC[-1])"
Case Else
Range(rngCol(a) & "1").FormulaR1C1 = "=IF(LEN(RC[-1])>50,LEFT(RC[-1],50),RC[-1])"
End Select
Range(rngCol(a) & "1").AutoFill Destination:=Range(rngCol(a) & "1:" & rngCol(a) & rngLen.Count), Type:=xlFillDefault
Range(rngCol(a) & "1:" & rngCol(a) & rngLen.Count).Select
Selection.Copy
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Columns(rngCol(a - 1) & ":" & rngCol(a - 1)).Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Next a
Cells.Replace What:="0", Replacement:="", LookAt:=xlWhole, _
SearchOrder:=xlByRows, MatchCase:=False
Set rngWhole = Range("AN1").End(xlDown)
Range(rngWhole.Address, Range("A1")).Select
Dim delimiter As String
Dim quotes As Integer
Dim Returned As String
delimiter = ""
'quotes = MsgBox("Surround Cell Information with Quotes?", vbYesNo)
' Call the WriteFile function passing the delimiter and quotes options.
Returned = WriteFile(delimiter, quotes)
' Print a message box indicating if the process was completed.
Select Case Returned
Case "Canceled"
MsgBox "The export operation was canceled."
Case "Exported"
MsgBox "The information was exported."
End Select
ActiveWorkbook.Close True
End Sub
