Public Sub ExcelToText(ByVal stfilepath As String)
'http://www.experts-exchange.com/Software/Office_Productivity/Office_Suites/MS_Office/Excel/Q_28277710.html
'http://www.developark.com/1529_17747527/
'http://www.mrexcel.com/forum/excel-questions/235867-using-column-numbers-define-range-visual-basic-applications.html
'Change the formatting of an excel file to text for all used cols (last col)
'Save as to another name (filename + txt.xlsx)
'Need to set a reference to Excel (tools references)
'20150228 ss
'Incorporated Version Check so file does not need to be reopened before import
'20150521
'Changed so no longer needs to set reference to excel
'Found that last col wasn't getting all data, switched to .cells without
'range in order to capture entire sheet.
'Changed to convert all reformatted files into Excel 2007-2013 format xlsx.
'-previously kept reformat in original version, but was causing issues down
'the road. Simplifies import process as all imported files are now the
'same format.
'201506??
'Added option to select a specific tab when doing a direct import
'need to reset sheet number to zero in the calling function when
'complete so that it won't use the wrong sheet number for normal
'operations
'http://stackoverflow.com/questions/15072098/saving-individual-sheet-in-excel-vba
'http://stackoverflow.com/questions/20632514/issue-on-saving-active-sheet-as-new-worksheet
'20160226
'Added code to trim the data to be imported
'20160227
Dim objapp As Object
Dim wb As Object
Dim lastCol As Long
Dim ExcelVersion As Long
Dim sheetIndex As Integer
Dim stReplace As String
Dim stReplacement As String
Dim stsql As String
Dim stSheetName As String
Dim stFileName As String
Dim stTableName As String
If globalintSheetIndex <> 0 Then
sheetIndex = globalintSheetIndex
Else
sheetIndex = 1
End If
On Error Resume Next
Set objapp = CreateObject("Excel.Application")
objapp.Visible = True
If Dir(stfilepath) <> "" Then
Set wb = objapp.Workbooks.Open(stfilepath, True, False)
' ElseIf Right(Dir(stfilepath), 3) = "csv" Then
' Set wb = objApp.Workbooks.Open(FilePath(stfilepath) & FileNameNoExt(stfilepath) & ".csv", True, False)
' ElseIf Right(Dir(stfilepath), 3) = "txt" Then
' Set wb = objApp.Workbooks.Open(FilePath(stfilepath) & FileNameNoExt(stfilepath) & ".txt", True, False)
End If
With wb.Sheets(sheetIndex)
.Activate
'lastcol = .cells(1, .Columns.Count).End(xlToLeft).Column
'.Range(.Columns(1), .Columns(lastcol)).NumberFormat = "@"
.Cells.NumberFormat = "@"
'wb.Cells.Replace What:="""", Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, ReplaceFormat:=False
'wb.Cells.Replace What:=Chr(34), Replacement:="", LookAt:=xlPart, MatchCase:=False
'Sub RemoveCarriageReturns()
lastrow = .Range("A1").CurrentRegion.Rows.Count
lastCol = .Range("A1").CurrentRegion.Columns.Count
'--Can Delete this section
'******************************************************
'This stopped working on 14-AUG so commented it out and
'hope it doesn't cause other problems
'.Name.Delete 'Delete Named range
'******************************************************
'SurveyMonkey macro code from Excel moved here to automate
'import of data from JSONtoCSV desktop conversion
'20170407
If (InStr(stfilepath, "DetailsMatrix") Or InStr(stfilepath, "RespondentData")) > 0 Then
objapp.DisplayAlerts = False
'If this is DetailsMatrix or RespondentData has no comments (col M), append as query
'to avoid col positional errors otherwise add Long Text to avoid truncation on import
If .Range("M1").value <> "data__pages__questions__answers__text" Then
If InStr(stfilepath, "DetailsMatrix") > 0 Then
stTableName = "SMDetailsMatrix"
Else
stTableName = "SMRespondentData"
End If
stSheetName = FileNameNoExt(stfilepath)
stFileName = FilePath(stfilepath) & FileNameNoExt(stfilepath) & "txt.xlsx"
'Query built here, but is run in frmSurveys
stsql = "INSERT INTO " & stTableName & " " & _
"SELECT T1.* " & _
"FROM [Excel 12.0;HDR=YES;IMEX=1;Database=" & stFileName & "].[" & stSheetName & "$A1:BB10000] AS T1;"
Forms!frmsurveys.txtSQL = stsql
Else
.Range("M2").value = "THIS IS LONG: Copy this into Cell M2 header should be data__pages__questions__answers__text !!!Do Not Delete!!! This needs to be done because otherwise if there are comments by the attendees that exceed 255 characters, the data will be truncated when pasted into Access."
End If
'Clean up header row by removing extra underscores and pipe symbols
stReplace = "__"
stReplacement = "_"
.Rows("1:1").Replace What:=stReplace, Replacement:=stReplacement, SearchOrder:=xlByRows
stReplace = "_|"
stReplacement = ""
.Rows("1:1").Replace What:=stReplace, Replacement:=stReplacement, SearchOrder:=xlByRows
objapp.DisplayAlerts = True
End If
'--Until Here
If InStr(stfilepath, "Date_Range_Courses") > 0 Then
.Cells(1, 1) = "UniqueKey"
.Cells(1, 2) = "Acronym"
.Cells(1, 3) = "EventCode"
.Columns(4).NumberFormat = "m/d/yyyy"
.Cells(1, 4) = "StartDate"
.Columns(5).NumberFormat = "m/d/yyyy"
.Cells(1, 5) = "EndDate"
.Columns(6).NumberFormat = "h:mm AM/PM"
.Cells(1, 6) = "StartTime"
.Columns(7).NumberFormat = "h:mm AM/PM"
.Cells(1, 7) = "EndTime"
.Cells(1, 8) = "EventTitle"
.Cells(1, 9) = "GeoArea"
.Cells(1, 10) = "INSTRUCTORS"
.Cells(1, 11) = "LocationName"
.Cells(1, 12) = "Registered"
ElseIf InStr(stfilepath, "LB_Event_Instructors_Fdn_Courses") > 0 Then
.Cells(1, 1) = "UniqueKey"
.Cells(1, 2) = "RecordNumber"
.Cells(1, 3) = "SortName"
.Cells(1, 4) = "FullName"
.Cells(1, 5) = "PrimaryEmail"
.Cells(1, 6) = "EventCode"
.Cells(1, 7) = "Acronym"
.Cells(1, 8) = "EventTitle"
.Columns(9).NumberFormat = "m/d/yyyy"
.Cells(1, 9) = "StartDate"
.Columns(10).NumberFormat = "h:mm AM/PM"
.Cells(1, 10) = "StartTime"
.Columns(11).NumberFormat = "m/d/yyyy"
.Cells(1, 11) = "EndDate"
.Columns(12).NumberFormat = "h:mm AM/PM"
.Cells(1, 12) = "EndTime"
.Cells(1, 13) = "CustomerID"
.Cells(1, 14) = "FirstName"
.Cells(1, 15) = "MiddleName"
.Cells(1, 16) = "LastName"
End If
End With
'wb.Sheets(1).Range("A:BB").NumberFormat = "@"
'http://www.rondebruin.nl/win/s5/win001.htm
'filefomatstuff 20150405
'wb.SaveAs FilePath(stfilepath) & FileNameNoExt(stfilepath) & "txt.xls", FileFormat:=56
'ElseIf Right(stfilepath, 1) = "v" Then
'wb.SaveAs FileName:=FilePath(stfilepath) & FileNameNoExt(stfilepath) & "txt.xlsx", FileFormat:=51
' ExcelVersion = wb.FileFormat
If globalintSheetIndex <> 0 Then
wb.ActiveSheet.Copy
objapp.ActiveWorkbook.SaveAs FilePath(stfilepath) & FileNameNoExt(stfilepath) & "txt.xlsx", FileFormat:=51
wb.Close savechanges:=False
Else
wb.SaveAs FilePath(stfilepath) & FileNameNoExt(stfilepath) & "txt.xlsx", FileFormat:=51
wb.Close 'savechanges:=False
End If
objapp.DisplayAlerts = True
objapp.Quit
Set objapp = Nothing
' Select Case ExcelVersion
' Case 39
' ExcelVersion = 5 'excel7
' Case 50, 51
' ExcelVersion = 9 'excel12 (2007-2013, xlsx)
' Case 56
' ExcelVersion = 8 'excel8 (97-2003 format in Excel 2007-2013, xls)
' End Select
' globalintExcelVer = ExcelVersion
End Sub