importing with variable file name - excel

each day I import some files into a master spreadsheet. The file has a time stamp random 8 digit number generated so I cant anticipate the file name. I previously had ???????? in place of the code which was working. After some IT changes it doesn't work now, we just changed drives and I updated the location all is fine if I add the sequence instead of ???'s
How can I make it so that I can mimic the effect I had before where ?????? worked - most of the file name is unique and can be estimated _ ( with dates etc.) but its just the last 8 digits.
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim filepath As String
filepath = Sheets("control").Cells(1, 5).Value
Application.ScreenUpdating = False
Set Wb1 = Workbooks.Open("C:\Users\damian_MCP\Mobius Capital Partners\Mobius _
Capital Partners Team Site - Documents\Operations\FTP\" & filepath & _
"\5446890_FMCM_" & filepath & "_(76765435).xls")
'current acc FMCM
... workaround for the this part
Set Wb1 = Workbooks.Open("C:\Users\damian_MCP\Mobius Capital Partners\Mobius_
Capital Partners Team Site - Documents\Operations\FTP\" & filepath & _
"\5446890_FMCM_" & filepath & "_(76765435).xls")
how can I edit this to search for just FMCM ?
Sub ubstransi()
Application.DisplayAlerts = False
Sheets("ubs trans").Select
' This section could have an unexpected result because it is not clear which cells are you clearing
Cells.Select
Selection.ClearContents
Dim Wb1 As Workbook
Dim Wb2 As Workbook
Dim filepath As String
filepath = Sheets("control").Cells(1, 5).Value
Set Wb1 = Workbooks.Open("C:\Users\damian_MCP\Mobius Capital Partners\Mobius Capital Partners Team Site - Documents\Operations\FTP\" & filepath & "\5446890_FMCM_" & filepath & "_(76882269).xls")
'FMCM *** NOTE that there is no wildcard in your code...
Wb1.Sheets("Cash Movement").Range("A1:x100").Copy
Windows("MEMF RECS2.xlsm").Activate
Sheets("ubs trans").Range("a1").PasteSpecial Paste:=xlPasteAll
Sheets("UBS trans").Select
Range("AD2").Select
ActiveCell.FormulaR1C1 = _
"=IF(AND((IF(OR(RC[-22]=""FOREX TRADE SPOT"",RC[-22]=""Transfer"",LEFT(RC[-22],5)=""UBSFX"",LEFT(RC[-22],6)=""UBS FX""),""FX"",0)=""FX""),RC[-21]=control!R2C3),""FX"",0)"
Range("AD2").Select
Selection.Copy
Range("AD100").Select
Range(Selection, Selection.End(xlUp)).Select
ActiveSheet.Paste
Application.CutCopyMode = False
Wb1.Close SaveChanges:=False
Set Wb2 = Workbooks.Open("C:\Users\damian_MCP\Mobius Capital Partners\Mobius Capital Partners Team Site - Documents\Operations\FTP\" & filepath & "\5446890_FMSH_" & filepath & "_(76885899).xls")
'FMSH *** NOTE that there is no wildcard in your code...
Wb2.Sheets("Securities Holdings").Range("A1:X100").Copy
Windows("MEMF RECS2.xlsm").Activate
Sheets("UBS AM POS").Range("a1").PasteSpecial Paste:=xlPasteAll
Wb2.Close SaveChanges:=False
Windows("MEMF RECS2.xlsm").Activate
Sheets("BBGCASH").Select
Range("A1").Select
Dim datename As String
Dim datename2 As String
datename = Sheets("control").Cells(1, 5).Value
datename2 = Sheets("control").Cells(2, 5).Value
' This instruction can not be handle as it is not setting to any var.
Workbooks.Open Filename:= _
"C:\Users\damian_MCP\Mobius Capital Partners\Mobius Capital Partners Team Site - Documents\Operations\FTP\" & datename & "\f3576cshdump2.ext." & datename2 & ".1.txt"
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=True, Other:=False, FieldInfo _
:=Array(1, 1), TrailingMinusNumbers:=True
Cells.Select
Selection.Copy
Windows("MEMF RECS2.xlsm").Activate
Sheets("BBGCASH").Select
Range("A1").Select
ActiveSheet.Paste
Sheets("control").Select
End Sub

Try this one:
Sub Open_Workboook()
Dim WB As Workbook
Dim MyPath As String, MyFile As String
Dim filepath as String
filepath = Sheets("control").Cells(1, 5).Value
MyPath = "C:\Users\damian_MCP\Mobius Capital Partners\Mobius _
Capital Partners Team Site - Documents\Operations\FTP\"
MyFile = Dir(MyPath & "*_FMCM_" & filepath & "_(76765435).xls")
Do While MyFile <> ""
Application.ScreenUpdating = False
Set WB = Workbooks.Open(MyPath & MyFile)
MyName = WB.Name
If MsgBox("Is this the file you want to open?" & vbTab & MyName, vbYesNo) = vbYes Then
GoTo continue
Else
WB.Close
End If
MyFile = Dir()
Loop
Exit Sub
continue:
WB.Close
MsgBox "File Find... and close " & MyName
End Sub
It will work, later just adapt.
Hope it helps

Related

Looping a recorded macro in Excel

I am not familiar with VBA so please forgive the simplicity of this question. I have a recorded macro which selects, opens then saves a file from a hyperlink in one of my columns. I just want to make a loop to repeat this macro down all of the rows in the worksheet which have data in them. Below is the code for the recorded macro, thank you all for your assistance.
Sub Extract()
'
'Extract Macro
'
'
Range("D2").Select
Selection.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:= _
"https://channele.corp.etradegrp.com/communities/teams02/performance-monitoring/TPEF%20Library/A2Consulting_Tech_5650_VSAF.xlsm"
ActiveWindow.Visible = False
Windows("A2Consulting_Tech_5650_VSAF.xlsm").Visible = True
ChDir "O:\Procurement Planning\QA"
ActiveWorkbook.SaveAs Filename:= _
"O:\Procurement Planning\QA\Copy of A2Consulting_Tech_5650_VSAF.xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
ActiveWindow.Close
End Sub
Something like this might work already:
Sub Extract()
Dim RngTarget As Range
Dim StrFileName As String
Set RngTarget = Range("D2")
Do Until RngTarget.Value = ""
RngTarget.Hyperlinks(1).Follow NewWindow:=False, AddHistory:=True
Workbooks.Open Filename:=RngTarget.Value
StrFileName = Split(RngTarget.Value, "/")(UBound(Split(RngTarget.Value, "/")))
Windows(StrFileName).Visible = True
Workbooks(StrFileName).SaveAs Filename:="O:\Procurement Planning\QA\Copy of " & Split(StrFileName, ".")(0) & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, _
CreateBackup:=False
Workbooks(StrFileName).Close
Set RngTarget = RngTarget.Offset(1, 0)
Loop
End Sub

Set the cell format to text in excel before importing

i am importing multiple text files in excel using the Macro given at this site
it is working but say for example u have data as 0010 it is changing it to 10 i tried to modify the code by adding
Destination:=Range("A1").NumberFormatLocal = "#" in the script but it is giving error
texttocoloums method of range class failed
here is the original code
Sub CombineTextFiles()
Dim FilesToOpen
Dim x As Integer
Dim wkbAll As Workbook
Dim wkbTemp As Workbook
Dim sDelimiter As String
On Error GoTo ErrHandler
Application.ScreenUpdating = False
sDelimiter = "|"
FilesToOpen = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, Title:="Text Files to Open")
If TypeName(FilesToOpen) = "Boolean" Then
MsgBox "No Files were selected"
GoTo ExitHandler
End If
x = 1
Set wkbTemp = Workbooks.Open(FileName:=FilesToOpen(x))
wkbTemp.Sheets(1).Copy
Set wkbAll = ActiveWorkbook
wkbTemp.Close (False)
wkbAll.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:="|"
x = x + 1
While x <= UBound(FilesToOpen)
Set wkbTemp = Workbooks.Open(FileName:=FilesToOpen(x))
With wkbAll
wkbTemp.Sheets(1).Move After:=.Sheets(.Sheets.Count)
.Worksheets(x).Columns("A:A").TextToColumns _
Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=False, Space:=False, _
Other:=True, OtherChar:=sDelimiter
End With
x = x + 1
Wend
ExitHandler:
Application.ScreenUpdating = True
Set wkbAll = Nothing
Set wkbTemp = Nothing
Exit Sub
ErrHandler:
MsgBox Err.Description
Resume ExitHandler
End Sub
Consider the following code. Run it , it works, does what you want. Might be a bit slower (if you don't have any blank lines in any of your notepad files you can remove If Len(lineData) > 0 Then & the end if. to speed it up again) but I think it always worth keeping those lines in, incase if you do have empty rows in any of your notepad files.
I was also going to refer you to Python which can convert .txt files to Excel, keep the formatting without any extra work, simpler. Pretty native of it to do so. So If you have python it might be better to use that to convert your notepad files to excel en-masse (they are short scripts no matter which method you use there), but in VBA I've refered to this for keeping the formatting & leading zeros, and this to create the structure to import my files.
Sub doIt6()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim InputTextFile As Variant
Dim SourceDataFolder As String, OutputDataFolder As String
SourceDataFolder = "C:\Users\User\Documents\Source_Data2 - Copy"
OutputDataFolder = "C:\Users\User\Documents\Output_Data - Copy"
'Loop through each text file in source folder
InputTextFile = Dir(SourceDataFolder & "\*.txt")
While InputTextFile <> ""
Workbooks.OpenText FileName:=SourceDataFolder & "\" & InputTextFile, DataType:=xlDelimited, Tab:=True
Dim myFileName As Variant
Dim myFileNames As Variant
Dim wb As Workbook
'myFileNames = Application.GetOpenFilename( _
' filefilter:="Excel Files,*.xl*;*.xm*", _
' title:="Select Excel File to Open", _
' MultiSelect:=True)
myFileNames = Application.GetOpenFilename _
(FileFilter:="Text Files (*.txt), *.txt", _
MultiSelect:=True, title:="Text Files to Open")
If Not IsArray(myFileNames) Then Exit Sub
For Each myFileName In myFileNames
Set wb = Workbooks.Open(myFileName, False, False)
'StandaloneReportEdit()'Sub to very thoroughly edit reports
Dim fn As Integer
Dim MyData As String
Dim lineData As String, strData() As String, myFile As String
Dim i As Long, rng As Range
'Workbooks.OpenText Filename:=SourceDataFolder & "\" & InputTextFile, DataType:=xlDelimited, Tab:=True
Set rng = Range("A1")
' Lets not rely on Magic Numbers
fn = FreeFile
Open myFileName For Input As #fn
i = 1
Do While Not EOF(fn)
Line Input #fn, lineData
If Len(lineData) > 0 Then
strData = Split(lineData, "|")
rng.Cells(i, 1).Resize(1, UBound(strData) + 1) = strData
End If
i = i + 1
Loop
Close #fn
ActiveWorkbook.SaveAs FileName:=OutputDataFolder & "\" & Replace(ActiveWorkbook.Name, ".txt", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
InputTextFile = Dir
Next
'Save each output file in output folder / maybe put this inside the loop
'ActiveWorkbook.SaveAs FileName:=OutputDataFolder & "\" & Replace(ActiveWorkbook.Name, ".txt", ".xlsx"), FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
'ActiveWorkbook.Close
'InputTextFile = Dir
Wend
End Sub
*note: I am at work, (day job). have lost many urls I was referring to (they are in chrome history but with no time to check on any others, & I must get on with my work) to do this, but can I re-edit this post and dig them up for you tonight if you need.
Does this answer your question ?
You could also import with Python. You could do this : (put your directory name containing all your the text files in mypath between the ' ''s)
Your files (csv's or .txt files) are read into dataframes, significantly as dtype='object' , which is the KEY here to preserving their formatting fully and keeping leading 000's in ALL txt source files when using the method.
I know there are 10000 other ways to do it much more elegantly (such as here and elsewhere) but I'm super happy I did it like this using Python as well.
from os import walk
import pandas as pd
from pathlib import Path
mypath=r'C:\Users\user\Documents\Data_Souce4\New Folder (2)'
f = []
df=[]
for (dirpath, dirnames, filenames) in walk(mypath):
f.extend(filenames)
#print(f)
#print(f[2])
for f in f:
ab=print(mypath+"\\"+f) #you an remove this - was just for me to see whats going on
str_path = mypath+"\\"+f
path=Path(str_path)
print(path)
df = pd.read_csv(path, dtype=('object'), sep=r'\\t')
df.to_excel(mypath + "\\" + f + '.xls', index=True, header=True)
break

For loop cannot detect the row and column

My script can detect rows and column in first round but in the second round cannot detect rows and column.
It shows
"run-time error '1004' : "\" could not be found.
Is there some missing code or is the sequence I put wrong?
Sub Conso()
' Get common values, eg. path, date
Call getValues
Workbooks("Daily Reporting Template.xlsm").Activate
Worksheets("Master").Activate
'Open Staff Input Value
Dim i As Integer
'Dim j As Long
'j = Cells(Rows.Count, 13).End(xlUp).Row
For i = 7 To 30
StaffPath = Cells(i, 4).Value
Ws = Cells(i, 3).Value
THPath = Cells(3, 2).Value
wrkFold = Cells(2, 2).Value
Filename = Cells(4, 2).Value
'Open Template
'Workbooks.Open Filename:= _
' wrkFold & "Master TH\Template\Daily Reporting Template.xlsm", UpdateLinks:=3
Windows("Daily Reporting Template.xlsm").Activate
Workbooks.Open Filename:= _
StaffPath & "\" & Filename & ".xlsm", UpdateLinks:=3
Cells.Select
Selection.Copy
Windows("Daily Reporting Template.xlsm").Activate
Sheets(Ws).Activate
Cells.Select
ActiveSheet.Paste
ActiveWorkbook.SaveAs Filename:= _
THPath & "Daily Reporting Template" & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
Application.DisplayAlerts = False
Windows(Filename & ".xlsm").Close
Next i
End Sub
Your code picks the value based on active sheet. This causes issues during Loop since it just refers to different file. Try the following code.
UnTested
Sub Conso()
Dim DailyRptTemplate As Workbook, MasterSht As Worksheet, TempWbk As Workbook
' Get common values, eg. path, date
Call getValues
Set DailyRptTemplate = Workbooks("Daily Reporting Template.xlsm")
Set MasterSht = DailyRptTemplate.Worksheets("Master")
Application.DisplayAlerts = False
'Open Staff Input Value
Dim i As Integer
'Dim j As Long
'j = Cells(Rows.Count, 13).End(xlUp).Row
For i = 7 To 30
StaffPath = MasterSht.MasterShtCells(i, 4).Value
WS = MasterSht.Cells(i, 3).Value
THPath = MasterSht.Cells(3, 2).Value
wrkFold = MasterSht.Cells(2, 2).Value
Filename = MasterSht.Cells(4, 2).Value
'Open Template
'Workbooks.Open Filename:= _
'wrkFold & "Master TH\Template\Daily Reporting Template.xlsm", UpdateLinks:=3
Set TempWbk = Workbooks.Open(Filename:=StaffPath & "\" & Filename & ".xlsm", UpdateLinks:=3)
TempWbk.Cells.Copy
DailyRptTemplate.Worksheets(WS).Range("A1").Paste
DailyRptTemplate.SaveAs Filename:=THPath & "Daily Reporting Template" & ".xlsm" _
, FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
TempWbk.Close (False)
Next i
Application.DisplayAlerts = True
End Sub
It is also worth to have look at the below section since these are not looped through the procedure.
THPath = MasterSht.Cells(3, 2).Value
wrkFold = MasterSht.Cells(2, 2).Value
Filename = MasterSht.Cells(4, 2).Value

copy specific excel sheets to a new workbook as values

Current code:
Private Sub cmdsave_Click()
Dim iRow As Long
Dim ws As Worksheet
Set ws = Worksheets("payin")
'find first empty row in database
iRow = ws.Cells.Find(What:="*", SearchOrder:=xlRows, _
SearchDirection:=xlPrevious, LookIn:=xlValues).Row + 1
'copy the data to the database
With ws
.Cells(iRow, 1).Value = Me.txtlbp.Value
.Cells(iRow, 2).Value = Me.txtdollar.Value
.Cells(iRow, 3).Value = Me.txtsyp.Value
End With
'clear the data
Me.txtlbp.Value = ""
Me.txtdollar.Value = ""
Me.txtsyp.Value = ""
ActiveWorkbook.Save
Dim savedate
savedate = Date
Dim savetime
savetime = Time
Dim formattime As String
formattime = Format(savetime, "hh.MM.ss")
Dim formatdate As String
formatdate = Format(savedate, "DD-MM-YYYY")
Application.DisplayAlerts = False
If Len(Dir("D:\cashbackup\english", vbDirectory)) = 0 Then
MkDir "D:\cashbackup\english"
End If
Dim backupfolder As String
backupfolder = "D:\cashbackup\english\"
ActiveWorkbook.SaveCopyAs Filename:=backupfolder & "payin" & formatdate & " " & formattime & " " & ActiveWorkbook.Name
Application.DisplayAlerts = False
txtlbp.SetFocus
End Sub
the current code is saving a copy of the whole file to the directory "D:\cashbackup\english", which is taking a lot of space on disk (about 3.73 MB for each save click), where as saving only sheets: payin, payout and balance as values only without the formulas created previously in excel cells in the excel project file will save much space on the hard disk (not more than 20 KB for each save click)
my need:
I want the code save a new workbook containing only specific sheets: payin, payout and balance as values in the directory: "D:\cashbackup\english", with the same file naming, I mean without the user forms in sheet BOX and without the macros
Thank you in advance.
New Version, but remember: The site it's not a place to find people that make your work, but a place to find an help for writed code... Or a starting point. The macro use the open file and make:
delete the sheets not included in the "list"
remove the formulas
put all the cells in protected mode
add password to all the sheets
save with password (for Open & Modify)
remove the macro from the files (saving in Xlsx)
Code:
Application.DisplayAlerts = False
For Each xx In ActiveWorkbook.Sheets
If xx.Name = "Sheet1" Or xx.Name = "Sheet3" Then
xx.Select
Cells.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Selection.Locked = True
ActiveSheet.Protect Password:="ShPwd", DrawingObjects:=True, Contents:=True, Scenarios:=True
Else
xx.Delete
End If
Next
tmp = " - " & Format(Date, "DD-MM-YYYY") & " - " & Format(Time, "HH-MM-SS")
ActiveWorkbook.Protect Password:="ShPwd", Structure:=True, Windows:=False
ActiveWorkbook.SaveAs Filename:="E:\0\New folder\aa" & tmp & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False, Password:="Open" _
, WriteResPassword:="Modify"
ActiveWindow.Close
Application.DisplayAlerts = True

Saving *.asc files as Excel files

I have *.asc files to open, reformat, and then save as an Excel file with the same name as the original (with the xls extension).
I used the Macro Recorder and code I found online to open individual files and reformat them as desired. That part of the code works.
I cannot save as an Excel file. It gives me the Run Time error of 1004 Method ‘SaveAs’ of object ‘_Workbook’ failed. I have tried lots of different code I found online (still in there, just commented out) but none work.
Two questions:
Can you offer suggestions to fix the SaveAs problem?
Can you offer suggestions of how to automate the opening and saving of all the files in one folder?
Here is the code I have:
Sub OpenFormatSave()
'
' OpenFormatSave Macro
'
Dim StrFileName As String
Dim NewStrFileName As String
ChDir _
"C:\Users\Owner\Documents\work_LLRS\GoM\NASA_data\Satellite_files_GoM_3Dec2012"
StrFileName = Application.GetOpenFilename("NASA Files (*.asc), *.asc")
If TypeName(StrFileName) <> "Boolean" Then
Workbooks.OpenText Filename:=StrFileName, _
Origin:=437, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=True, 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)), TrailingMinusNumbers:=True
End If
Rows("1:1").Select
Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
Range("A1").Select
ActiveCell.FormulaR1C1 = "Year"
Range("B1").Select
ActiveCell.FormulaR1C1 = "Day_of_Year"
Range("C1").Select
ActiveCell.FormulaR1C1 = "Longitude"
Range("D1").Select
ActiveCell.FormulaR1C1 = "Latitude"
Range("E1").Select
ActiveCell.FormulaR1C1 = "Chla_mg_m-3"
Range("F1").Select
ActiveCell.FormulaR1C1 = "POC_mmolC_m-3"
Range("G1").Select
ActiveCell.FormulaR1C1 = "SPM_g_m-3"
Range("H1").Select
ActiveCell.FormulaR1C1 = "aCDOM355_m-1"
Range("I1").Select
ActiveCell.FormulaR1C1 = "DOC_mmolC_m-3"
Range("J1").Select
ActiveCell.FormulaR1C1 = "L2_flags"
Columns("A:B").Select
Selection.NumberFormat = "0"
Columns("C:D").Select
Selection.NumberFormat = "0.0000"
Columns("E:E").Select
Selection.NumberFormat = "0.000"
Columns("F:F").Select
Selection.NumberFormat = "0.0"
Columns("G:H").Select
Selection.NumberFormat = "0.000"
Columns("I:I").Select
Selection.NumberFormat = "0.0"
Columns("J:J").Select
Selection.NumberFormat = "0.00E+00"
'Mid(StrFileName, 1, InStrRev(StrFileName, ".")) = "xlsm"
'With ActiveWorkbook
'NewStrFileName = Replace(.StrFileName, ".asc", ".xls")
' .SaveAs Filename:=FullName, FileFormat:=xlsx, AddToMRU:=False
' .Close SaveChanges:=True
'End With
StrFileName = ThisWorkbook.Name
GetName:
StrFileName = Application.GetSaveAsFilename(NewStrFileName, _
fileFilter:="(*.xlsm), *.xlsm, (*.xlsx), *.xlsx,(*.xls), *.xls")
' FileMonth is the Workbook name, filter options to save a older version file
'If Dir(NewStrFileName) = "" Then
' ActiveWorkbook.SaveAs NewStrFileName
'Else
' If MsgBox("That file exists. Overwrite?", vbYesNo) = vbNo Then GoTo GetName
' Application.DisplayAlerts = False
' ActiveWorkbook.SaveAs Filename:=NewStrFileName, FileFormat:=xlsx, AddToMRU:=False
'Application.DisplayAlerts = True
'End If
'ActiveWorkbook.Close SaveChanges:=True
ActiveWorkbook.SaveAs Filename:=NewStrFileName, FileFormat:=xlsx, CreateBackup:=False
'With ThisWorkbook
'FullName = Replace(.StrFileName, ".asc", ".xlsx")
'.Save
'.SaveAs StrFileName, FileFormat:=xlsx
'.Close
'SaveChanges:=True
'End With
'StrFileName = Split(ActiveWorkbook.FullName, ".xls")(0)
'ActiveWorkbook.SaveAs Filename:="...", FileFormat:=xlsx, AddToMRU:=False
'ActiveWorkbook.Close SaveChanges:=True
'ActiveWorkbook.Save
End Sub
Change the FileFormat portion of your SaveAs method to this:
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
To iterate through all the files in a folder, you have two options.
Use the built-in VBA Dir function.
Use methods in FileSystemObject.
I'll give an example of Dir because it doesn't require adding a reference in your VBA project. Unfortunately the Dir interface is a lot less intuitive and less modern than FileSystemObject.
Dim path As String
path = Dir("C:\Users\example\Documents\AscFiles\*.asc")
Do
If path = vbNullString Then Exit Do
' do something with path here
Debug.Print path
path = Dir
Loop
You have two variables StrFileName (presumably intended as the current filename) and NewStrFileName (presumably intended to be the new filename).
In this piece of code:
StrFileName = Application.GetSaveAsFilename(NewStrFileName, _
fileFilter:="(*.xlsm), *.xlsm, (*.xlsx), *.xlsx,(*.xls), *.xls")
you have used these variables the wrong way round. The suggested filename when the "Save As" dialog opens is based on NewStrFileName but this has never been given a value and is thus an empty string "". The value chosen by the user is then saved into StrFileName
When you come to save the file with this code:
ActiveWorkbook.SaveAs Filename:=NewStrFileName, FileFormat:=xlsx, _
CreateBackup:=False
the NewStrFileName variable still contains "" and thus you are trying to save a file without giving it a name which obviously produces an error.
For a simple fix, just swap the two variables in the call to GetSaveAsFilename:
NewStrFileName = Application.GetSaveAsFilename(StrFileName, _
fileFilter:="(*.xlsm), *.xlsm, (*.xlsx), *.xlsx,(*.xls), *.xls")
This is not the best way to achieve what you want but it should at least work
here is a very simply code to convert a folder of ASC files to Excel files. It also works with CSV files. So all you have to do is change the .asc to .csv
Just make sure you set the delimiter to TAB wherever you are getting the data from.
Sub import_ascFile()
Dim file As FileDialog
Dim filePath As String
Dim text As String
Dim wsheet As String
Application.DisplayAlerts = False
Application.StatusBar = True
wsheet = ActiveWorkbook.Name
Set file = Application.FileDialog(msoFileDialogFolderPicker)
file.Title = "Folder Selection:"
If file.Show = -1 Then
filePath = file.SelectedItems(1)
Else
Exit Sub
End If
If Right(filePath, 1) <> "\" Then filePath = filePath + "\"
text = Dir(filePath & "*.asc")
Do While text <> ""
Application.StatusBar = "Converting: " & text
Workbooks.Open Filename:=filePath & text
ActiveWorkbook.SaveAs Replace(filePath & text, ".asc", ".xlsx", vbTextCompare), xlWorkbookDefault
ActiveWorkbook.Close
Windows(wsheet).Activate
text = Dir
Loop
Application.StatusBar = False
Application.DisplayAlerts = True
End Sub

Resources