I have some vba code which loops through all csv-files in a folder. It saves a file but does not split text into columns.
When I step through the code using F8, I can see that the text is split to columns, but when reopening the modified file I can't see the text having been split.
I am trying to open each file, split text to columns, and then save and go to the next file. I want to this for all files in a folder of my choice. Each folder may contain thousands of files.
Sub LoopAllExcelFilesInFolder()
'PURPOSE: To loop through all Excel files in a user specified folder and perform a set task on them
'SOURCE: www.TheSpreadsheetGuru.com
Dim wb As Workbook
Dim myPath As String
Dim myFile As String
Dim myExtension As String
Dim FldrPicker As FileDialog
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
'Retrieve Target Folder Path From User
Set FldrPicker = Application.FileDialog(msoFileDialogFolderPicker)
With FldrPicker
.Title = "Select A Target Folder"
.AllowMultiSelect = False
If .Show <> -1 Then GoTo NextCode
myPath = .SelectedItems(1) & "\"
End With
'In Case of Cancel
NextCode:
myPath = myPath
If myPath = "" Then GoTo ResetSettings
'Target File Extension (must include wildcard "*")
myExtension = "*.csv*"
'Target Path with Ending Extention
myFile = Dir(myPath & myExtension)
'Loop through each Excel file in folder
Do While myFile <> ""
'Set variable equal to opened workbook
Set wb = Workbooks.Open(filename:=myPath & myFile)
'Ensure Workbook has opened before moving on to next line of code
DoEvents
'Change First Worksheet's Background Fill Blue
wb.Worksheets(1).Range("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=True, _
Semicolon:=True, Comma:=True, Space:=True, Other:=True, OtherChar:= _
"|", 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)), TrailingMinusNumbers:=True
Range("A1").Select
'Save and Close Workbook
wb.Close SaveChanges:=True
'Ensure Workbook has closed before moving on to next line of code
DoEvents
'Get next file name
myFile = Dir
Loop
'Message Box when tasks are completed
MsgBox "Task Complete!"
ResetSettings:
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
You may be saving the file back to csv. You should save the file in xlsx, this way:
wb.SaveAs Filename:=split(myfile, ".")(0), FileFormat:=xlOpenXMLWorkbook
And please apply #Luuklag's suggestion, too.
Related
I am trying to copy multiple txt file into excel but having a little issue on the following:
Sub devise(FICHIER, FEUILLE)
Dim wb As Workbook: Set wb = ThisWorkbook
Dim ws As Worksheet: Set ws = wb.Worksheets(FEUILLE)
Dim wbcopy As Workbook
ChDir "R:\Oco_R\Valoco"
Workbooks.OpenText Filename:="R:\Oco_R\Valoco\" & FICHIER, Origin:= _
xlWindows, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:= _
Array(Array(0, 1), Array(6, 1), Array(26, 1), Array(35, 1), Array(46, 1), _
Array(53, 1), Array(64, 1), Array(72, 1))
Selection.Copy
ws.Activate
ws.Range("A1").PasteSpecial
'ActiveSheet.Paste
ws.Rows("1:4").Delete Shift:=xlUp
ws.Cells.Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:= _
xlTopToBottom
Application.CutCopyMode = False
ActiveWorkbook.Close
End Sub
I already defined the workbook where I would like the txt to be copied to. But I was wondering how I could DIM the txt file so that I can close it? For example FIHCIER.close, but doesn't work of course...
In the code I'm using ActiveWorkbook.Close but it is referring to my excel file which I don't want to close.
I tried using a Set wbC but haven't really succeeded...
Thank you very much for your help!
When you open a textfile using Workbooks.OpenText, Excel will create a workbook (containing one sheet) from the text file.
For some strange reasons OpenText is not implemented as function (in opposite to Workbooks.Open`), so you can't do something like
set txtFile = Workbooks.OpenText(MyTextFileName)
However, after you open the file, it is automatically the ActiveWorkbook, so you can do the following:
Dim txtFile as Workbook
Workbooks.OpenText filename:=MyTextFileName
Set txtFile = ActiveWorkbook
(...)
txtFile.close saveChanges:=False
I am trying to import a large txt. file into excel. The whole process works, but is very time consuming (16-17 s). Is there any way to make it more time effective?
My code looks like this:
Sub Dane_wprowadz() ' icon folder
Dim Plik As String
Dim Katalog As String
Dim Sciezka As String
CzasStart = Timer
'Screen update hidden
Application.ScreenUpdating = False
'Gridline hidden
ActiveWindow.DisplayGridlines = False
'Import of txt file origin
Katalog = InputBox("Proszę podać katalog gdzie znajdują się dane", "Lokalizacja danych", ActiveWorkbook.Path & "\dane") & "\"
'New Sheet
Sheets.Add After:=Sheets(Sheets.Count)
'Headers in new sheet
ActiveSheet.Range("A1") = "Brand"
ActiveSheet.Range("B1") = "Produkt"
ActiveSheet.Range("C1") = "Tydzień"
ActiveSheet.Range("D1") = "Sprzedaż"
ActiveSheet.Range("E1") = "Województwo"
ActiveSheet.Range("F1") = "Miasto"
ActiveSheet.Range("A1").Select
'Import txt 1
Plik = Dir(Katalog)
Do While Plik <> ""
'Path import
Sciezka = Katalog & Plik
'Data import of the txt file
Workbooks.OpenText Filename:=Sciezka, _
Origin:=1250, StartRow:=2, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=False, Space:=False, Other:=True, OtherChar:="-", FieldInfo:= _
Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5, 1), Array(6, 1)), _
TrailingMinusNumbers:=True
'Copy imported data to "Dane
Selection.CurrentRegion.Copy (ThisWorkbook.Sheets("Dane").Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
ActiveWindow.Close False 'close without saving
'Next txt file
Plik = Dir
Loop
'Start screen upadting
Application.ScreenUpdating = True
'Return to control panel
Sheets("Panel kontrolny").Select
CzasStop = Timer
MsgBox "Czas prodecury " & CzasStop - CzasStart & "s"
End Sub
It is probably the txt import that takes up the most time. Is there any way to make it more effective?
Unless VBA is necessary, you can use PowerQuery. I found it to be relatively faster and can do pretty much what you need.
Go Data->GetData->FromFile->FromText/CSV
Heading ## I was able to get the selection to select active Cell a1 but now receive error 1004 Application Object-defined error, AT THE SECTION OF CODE <Sheets.Add before:=Workbooks(myFile).Sheets("Make DMS Report")>
Please see the code below.
The code filters the data from Agile export and filters the product Part number and associates the manufacture part number with the part.
'Start code
<Sub ImportAgileBOM()
'GoTo test1
Dim FullFileName As String
Dim myFile As String
Dim FileFormat As String
Dim rng As Range
'Open .cvs worksheet and convert to text format.
myFile = ActiveWorkbook.Name
FullFileName = Application.GetOpenFilename("Text files , *.csv; *.txt,Excel files (*.xls*), *.xls*", 2, "Select Agile Mfr BOM Report", , False)
If FullFileName = "False" Then
Application.DisplayAlerts = True
End
End If
'This section converts the .cvs and renames workboot to text
If Right(FullFileName, 4) = ".csv" Or Right(FullFileName, 4) = ".txt" Then
FileCopy FullFileName, FullFileName & "importtemp.txt"
FileFormat = "Text"
Workbooks.OpenText Filename:=FullFileName & "importtemp.txt", _
DataType:=xlDelimited, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, _
FieldInfo:=Array(Array(1, 2), Array(2, 2), Array(3, 2), Array(4, 2), Array(5, 2), Array(6, 2), Array(7, 2), Array(8, 2))
Else
FileFormat = "Excel"
Workbooks.Open Filename:=FullFileName
End If
'Make Active Range
Set rng = ActiveSheet.Range("A1")
'Range("A1").Activate
If FileFormat = "Text" Then
If ActiveCell <> "Manufacturer BOM Report" Then
MsgBox "Input file not in Manufacturer BOM Report format"
ActiveWindow.Close
Application.DisplayAlerts = True
End
End If
ElseIf ActiveCell.Offset(0, 1) <> "Manufacturer BOM Report" Then
MsgBox "Input file not in Manufacturer BOM Report format"
ActiveWindow.Close
Application.DisplayAlerts = True
End
End If
'FullFileName = ActiveWorkbook.Name
'Sheets(ActiveSheet.Name).Copy Sheets.Add Sheet.before:=Workbooks(myFile).Sheets("Make DMS Report")
'Windows(FullFileName).Activate
'ActiveWindow.Close savechanges:=False
'Copy data to secound sheet
FullFileName = ActiveWorkbook.Name
Cells.Select
Selection.Copy
Workbooks(myFile).Activate
Sheets.Add before:=Workbooks(myFile).Sheets("Make DMS Report")
ActiveSheet.Paste>
'I receive the error when trying to add the created sheet to the Active sheet.
If you could assist in this issue it would be appreciated
I am now receiving an error at <Range("A1"). select> the error message is Run-time error 1004 Application-defined Or Object-defined error, I don't understand why I am receiving this error, just selecting a cell
I've borrowed some code from a post on this site already and made my own. However I'm running into a problem where the multiple files in my folder path are importing OVER the previous import instead of below the created list.
What I'm trying to achieve is importing data from multiple files in a specific folder location. After pursing through each file, the next import data should be placed under the previous import data in the worksheet.
Any insights on how to fix?
Thanks so much!
cwegz
Option Explicit
Const FOLDER_PATH = "Test Folder Path/" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
'=============================================
'Process all Excel files in specified folder
'=============================================
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim rowTarget As Long 'output row
rowTarget = 2
'check the folder exists
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
'reset application settings in event of error
On Error GoTo errHandler
Application.ScreenUpdating = False
'set up the target worksheet
Set wsTarget = Sheet1
'loop through the Excel files in the folder
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
'open the source file and set the source worksheet - ASSUMED WORKSHEET(1)
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets(1) 'EDIT IF NECESSARY
'import the data
With wsTarget
.Columns("A").Value = wsSource.Columns("A").Value 'this one works
.Columns("B").Value = wsSource.Columns("C").Value 'this one works
'.Range("A1" & rowTarget).Value = wsSource.Columns("A").Value
'.Range("B1" & rowTarget).Value = wsSource.Columns("C").Value
'optional source filename in the last column
.Range("N" & rowTarget).Value = sFile
End With
'close the source workbook, increment the output row and get the next file
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + 1
sFile = Dir()
Loop
errHandler:
On Error Resume Next
Application.ScreenUpdating = True
'tidy up
Set wsSource = Nothing
Set wbSource = Nothing
Set wsTarget = Nothing
Set Selection = Nothing
Sheets("Pull").Select
Columns("B:B").Select
Selection.TextToColumns Destination:=Range("C1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="#", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Set Selection = Nothing
Sheets("Pull").Select
Columns("D:D").Select
Selection.TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:=";", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Set Selection = Nothing
Sheets("WhiteList").Select
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("K1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
:="#", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True
Set Selection = Nothing
Sheets("Summary").Select
End Sub
Here's one approach, which should work if your data tables are consistent and contain no blank rows/columns.
Option Explicit
Const FOLDER_PATH = "Test Folder Path\" 'REMEMBER END BACKSLASH
Sub ImportWorksheets()
Dim sFile As String 'file to process
Dim wsTarget As Worksheet
Dim wbSource As Workbook
Dim wsSource As Worksheet, rngData As Range, numRows As Long
Dim rowTarget As Long 'output row
If Not FileFolderExists(FOLDER_PATH) Then
MsgBox "Specified folder does not exist, exiting!"
Exit Sub
End If
On Error GoTo errHandler
Application.ScreenUpdating = False
Set wsTarget = Sheet1
'get first empty row, assuming colA always has values
rowTarget = wsTarget.Cells(Rows.Count, 1).End(xlUp).Row + 1
sFile = Dir(FOLDER_PATH & "*.xls*")
Do Until sFile = ""
Set wbSource = Workbooks.Open(FOLDER_PATH & sFile)
Set wsSource = wbSource.Worksheets(1)
Set rngData = wsSource.Range("A1").CurrentRegion '<< assumes no empty rows/columns in your data table
numRows = rngData.Rows.Count '<<
With wsTarget
.Cells(rowTarget, "A").Resize(numRows, 1).Value = rngData.Columns(1).Value
.Cells(rowTarget, "B").Resize(numRows, 1).Value = rngData.Columns(3).Value
'etc etc
.Cells(rowTarget, "N").Value = sFile 'optional source filename in the last column
End With
wbSource.Close SaveChanges:=False
rowTarget = rowTarget + numRows '<<
sFile = Dir()
Loop
'snipped....
End Sub
I have a relatively simple macro. It takes in a user selected text file and uses fixed width delimiters to cut it into columns that are always the same. My problem is that when I run my macro the selected file will open, however it doesn't perform the text-to-columns.
It will perform this whenever you step-through the macro. It also works when you use the macro on the same file twice in a row.
Sub Historical()
With Application.FileDialog(msoFileDialogFilePicker)
'Only one file
.AllowMultiSelect = False
'Add filters
.Filters.Add "All", "*.*"
'Show the dialog box
.Show
'Store in fullpath variable
fullpath = .SelectedItems.Item(1)
End With
Dim WrkBk As Workbook
Dim WrkSht As Worksheet
Dim sheetname As String
Set WrkBk = Workbooks.Open(fullpath)
'Code stops here. The file will open but nothing below happens. I tried adding a wait.
Application.Wait (Now + TimeValue("0:00:02"))
Columns("A:A").Select
Selection.TextToColumns Destination:=Range("A1"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(14, 1), Array(17, 9), Array(18, 1), Array(23, 9), _
Array(24, 1), Array(30, 1), Array(62, 1), Array(72, 1), Array(84, 1), Array(94, 1), Array( _
118, 1)), TrailingMinusNumbers:=True
End Sub
Figured it out. It was because I was using the Shift key in the hotkey for the macro which was causing problems with the Workbooks.Opencommand.