Related
I have a large list of .txt files that I need to have a macro that does the following:
Open Files
Delimit the file based on "|"
Select all then filter
Sort on a specific header
Steps 3 and 4 are easy... If these files weren't all .txt with | delimiters, I know how to open multiple files and then filter/sort, the issue I run into is step 2.
Code so far:
Option Explicit
Dim theDir As String, wk As Workbook, numFiles As Integer, s As String, r As Range
Const ext = ".txt"
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
theDir = ThisWorkbook.Path
s = Dir(theDir & "\*" & ext)
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.txt*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
'your code here
Set r = Range(Range("A1"), Range("A1").End(xlDown))
r.TextToColumns Destination:=r, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, _
Semicolon:=False, Comma:=True, 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), _
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), Array(32, 1), Array( _
33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array( _
46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), _
Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array( _
59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array(64, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = False
s = Dir()
numFiles = numFiles + 1
xFileName = Dir
End With
Loop
End If
End Sub
This code works... but only for the first column, I have upwards of 70 columns in some documents.
You could use the Workbooks.OpenText method - a bit easier to manage I think
Sub Tester()
Dim wb As Workbook
Set wb = GetWorkbook("C:\Temp\pipes.txt")
Debug.Print wb.Name
End Sub
Function GetWorkbook(fpath) As Workbook
Workbooks.OpenText Filename:=fpath, Origin:=437, StartRow:= _
1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=False, Semicolon:=False, Comma:=False _
, Space:=False, Other:=True, OtherChar:="|", TrailingMinusNumbers:=True
Set GetWorkbook = ActiveWorkbook
End Function
You are selecting the first column in this line of code.
Set r = Range(Range("A1"), Range("A1").End(xlDown))
This should be OK if the files are text delimited by the pipe symbol.
However if there are commas in the files, it will automatically break data after the comma into another column.
Try opening the files directly in text mode.
As an example
Workbooks.OpenText Filename:="C:\Temp\Test1.txt", _
Origin:=xlMSDOS, StartRow:=1, 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), Array(3, 1), Array(4, 1), Array(5, 1)), _
TrailingMinusNumbers:=True
I got this to work:
Option Explicit
Dim theDir As String, wk As Workbook, numFiles As Integer, s As String, r As Range
Const ext = ".txt"
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
theDir = ThisWorkbook.Path
Dim wkbpath As String
Dim wkbname As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem) ' old version had: & "*.txt*")
Do While xFileName <> ""
With Workbooks.Open(xFdItem & xFileName)
'your code here
Set r = Range(Range("A1"), Range("A1").End(xlDown))
r.TextToColumns Destination:=r, 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), _
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), Array(32, 1), Array( _
33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array(38, 1), Array(39, 1), _
Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), Array( _
46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array(51, 1), Array(52, 1), _
Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), Array(58, 1), Array( _
59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array(64, 1)), TrailingMinusNumbers:=True
Application.DisplayAlerts = False
Cells.Select
Selection.AutoFilter
Application.AddCustomList ListArray:=Array("PREFERRED", "NON-PREFERRED", _
"UNACCEPTABLE", "OBSOLETE")
ActiveSheet.Sort.SortFields. _
Clear
ActiveSheet.Sort.SortFields. _
Add Key:=Range("D2:D479"), SortOn:=xlSortOnValues, _
CustomOrder:="PREFERRED,NON-PREFERRED,UNACCEPTABLE,OBSOLETE", DataOption:= _
xlSortNormal
With ActiveSheet.Sort
.SetRange Range("A1:BH79")
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
xFileName = Dir
wkbpath = "C:\Users\tomas.breitinger\Desktop\BAE Export .DAT Files\Finished\"
wkbname = ActiveWorkbook.Name
ActiveWorkbook.SaveAs Filename:= _
wkbpath & wkbname & ".xlsx", FileFormat:=51, CreateBackup:=False
ActiveWorkbook.Close savechanges:=False
End With
End With
Loop
End If
End Sub
I'm trying to convert a range of data, from text to columns, with VBA.
When I apply the code some cells with date don't convert as date. If then you enter the cell and press "enter" it converts to date format.
Selection.TextToColumns _
Destination:=Range("A1"), _
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, 4), Array(7, 8), Array(8, 4), Array(9, 4), Array(10, 4), _
Array(11, 4), Array(12, 4), 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), Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), _
Array(36, 1), Array(37, 1), Array( 38, 1), Array(39, 1), Array(40, 1), _
Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), Array(45, 1), _
Array(46, 1)),
DecimalSeparator:=".", _
ThousandsSeparator:=",", _
TrailingMinusNumbers:=True
In the array, cells 6 to 12 is where the dates are.
I cannot update any of the data due to data protection policy. But here is a small sample where also happens the same problem. All the text is in the same column A1 and each line in a different row
20191284809$$BT$Anulado$23/05/2019 09:22:57
20191304047$$BT$Anulado$04/06/2019 20:29:03
20191159599$$BT$Anulado$01/03/2019 11:53:10
20191165919$$BT$Anulado$06/03/2019 11:33:18
20191247883$$BT$Anulado$27/04/2019 14:54:17
20191381935$$BT$Cerrado$22/07/2019 01:12:03
20191404309$$BT$Cerrado$03/08/2019 08:56:55
I have a column BA. I want to do Text to Column to column BC.
I recorded a macro. When I execute it in a workbook I get an error.
Here is my recorded macro.
Sub Macro8()
'
' Macro8 Macro
'
' Keyboard Shortcut: Ctrl+Shift+H
'
Selection.TextToColumns Destination:=ActiveCell.Offset(0, 2).Range("A1"), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter _
:=True, Tab:=False, Semicolon:=False, Comma:=True, 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), 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), Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), Array( _
36, 1), Array(37, 1), Array(38, 1)), TrailingMinusNumbers:=True
End Sub
Shouldn't Range be BA?
I don't see BC - is that the 0, 2 offset?
EDIT: changed the destination offset to two columns over (from 1)
If you just need your code to operate on the selected cells then this should work:
Selection.TextToColumns Destination:=Selection.Offset(0, 2), _
DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Comma:=True, Other:=True, _
OtherChar:=":"
Unless you have specific datatypes etc you want to apply to the resulting columns, you can typically omit the FieldInfo argument
I was running Marco to open all the .txt file in the list at ChDir.
And append data from the .txt to the Master file .xls.
But when run the script , the .txt file will be open with .xls in the PC .
If there are 5 .txt file , it will open 5 .xls file.
My question is how can i close all the 5 .xls file once script have append needed data into it?
I do not want to close it manually because the input file might be a lot in future. Thanks.
Sub Macro1()
For r = 2 To 400
c = 1
If (Sheets("File").Cells(r, c)) = "" Then
r = 401
Else
ChDir "C:\Users\csleow\Desktop\wafermap_stack"
Workbooks.OpenText Filename:= _
Sheets("File").Cells(r, c) _
, Origin:=437, StartRow:=1, DataType:=xlFixedWidth, FieldInfo:=Array( _
Array(0, 1), Array(5, 1), Array(10, 1), Array(15, 1), Array(20, 1), Array(25, 1), Array(30, _
1), Array(35, 1), Array(40, 1), Array(45, 1), Array(50, 1), Array(55, 1), Array(60, 1), _
Array(65, 1), Array(70, 1), Array(75, 1), Array(80, 1), Array(85, 1), Array(90, 1), Array( _
94, 1), Array(99, 1), Array(104, 1), Array(109, 1), Array(114, 1), Array(119, 1), Array(124 _
, 1), Array(129, 1), Array(134, 1), Array(139, 1), Array(144, 1), Array(149, 1), Array(154, _
1), Array(159, 1), Array(164, 1), Array(169, 1), Array(174, 1), Array(179, 1), Array(184, 1 _
), Array(189, 1), Array(194, 1), Array(199, 1), Array(204, 1), Array(209, 1), Array(214, 1) _
, Array(219, 1), Array(224, 1), Array(229, 1), Array(234, 1), Array(239, 1), Array(244, 1), _
Array(249, 1), Array(254, 1), Array(259, 1), Array(264, 1), Array(269, 1), Array(274, 1), _
Array(279, 1), Array(284, 1), Array(289, 1), Array(294, 1), Array(299, 1), Array(304, 1), _
Array(309, 1), Array(315, 1), Array(320, 1), Array(325, 1), Array(330, 1), Array(335, 1), _
Array(340, 1), Array(345, 1), Array(350, 1), Array(355, 1), Array(360, 1)), _
TrailingMinusNumbers:=True
Cells.Select
Selection.Copy
Windows("Composite_9221.xlsm").Activate
Sheets("Temp").Select
Range("A1").Select
ActiveSheet.Paste
Range("A1").Select
Macro3
End If
Next
End Sub
Try this:
For Each WkbkName In Application.Workbooks()
If WkbkName.Name <> ThisWorkbook.Name Then WkbkName.Close SaveChanges:=True
Next
(source)
EDIT: Since you're appending data to your 5 xls files, then I assume you need to save these workbooks before closing.
#Nathan_Sav: Code edited!
After opening the TXT file and copying the information to the Composite workbook, you should be able to close each one in sequence as you use it.
Sub Macro1()
Dim r As Long, c As Long, fp As String
fp = "C:\Users\csleow\Desktop\wafermap_stack" & Chr(92)
With Worksheets("file")
For r = 2 To 400
c = 1
If .Cells(r, c) = "" Then
r = 401
Else
With .Parent.OpenText(Filename:=fp & Cells(r, c), _
Origin:=437, StartRow:=1, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(5, 1), Array(10, 1), Array(15, 1), _
Array(20, 1), Array(25, 1), Array(30, 1), Array(35, 1), _
Array(40, 1), Array(45, 1), Array(50, 1), Array(55, 1), _
Array(60, 1), Array(65, 1), Array(70, 1), Array(75, 1), _
Array(80, 1), Array(85, 1), Array(90, 1), Array(94, 1), _
Array(99, 1), Array(104, 1), Array(109, 1), Array(114, 1), _
Array(119, 1), Array(124, 1), Array(129, 1), Array(134, 1), _
Array(139, 1), Array(144, 1), Array(149, 1), Array(154, 1), _
Array(159, 1), Array(164, 1), Array(169, 1), Array(174, 1), _
Array(179, 1), Array(184, 1), Array(189, 1), Array(194, 1), _
Array(199, 1), Array(204, 1), Array(209, 1), Array(214, 1), _
Array(219, 1), Array(224, 1), Array(229, 1), Array(234, 1), _
Array(239, 1), Array(244, 1), Array(249, 1), Array(254, 1), _
Array(259, 1), Array(264, 1), Array(269, 1), Array(274, 1), _
Array(279, 1), Array(284, 1), Array(289, 1), Array(294, 1), _
Array(299, 1), Array(304, 1), Array(309, 1), Array(315, 1), _
Array(320, 1), Array(325, 1), Array(330, 1), Array(335, 1), _
Array(340, 1), Array(345, 1), Array(350, 1), Array(355, 1), _
Array(360, 1)), _
TrailingMinusNumbers:=True)
.Worksheets(1).Cells(1, 1).CurrentRegion.Cells.Copy _
Destination:=Workbooks("Composite_9221.xlsm").Worksheets("Temp").Range("A1")
.Close savechanges:=False
End With
'done with the the TXT fle, close it
'I don't know what this does
Macro3
End If
Next r
End With
End Sub
I did not set up a full test environment to this but is cycled through the three TXT I created with limited fields.
I'm trying to make my VBA destination to the cell below the ActiveCell. Right now, it only wants to place it in R2. I have tried using offset to shift it down a cell, but haven't had any luck. The array would typically hold something like Doe, John JDoe11#email.com.
Sub MailMergeNames()
'
' MailMergeNames Macro
'
' Keyboard Shortcut: Ctrl+Shift+M
'
'
' Shift line to rows
'
Selection.TextToColumns Destination:=Range("R1"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
Semicolon:=True, Comma:=False, Space:=False, Other:=False, 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), 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), _
Array(32, 1), Array(33, 1), Array(34, 1), Array(35, 1), Array(36, 1), Array(37, 1), Array( _
38, 1), Array(39, 1), Array(40, 1), Array(41, 1), Array(42, 1), Array(43, 1), Array(44, 1), _
Array(45, 1), Array(46, 1), Array(47, 1), Array(48, 1), Array(49, 1), Array(50, 1), Array( _
51, 1), Array(52, 1), Array(53, 1), Array(54, 1), Array(55, 1), Array(56, 1), Array(57, 1), _
Array(58, 1), Array(59, 1), Array(60, 1), Array(61, 1), Array(62, 1), Array(63, 1), Array( _
64, 1), Array(65, 1), Array(66, 1), Array(67, 1)), TrailingMinusNumbers:=True
Range("R1:CJ1").Select
Selection.Copy
Range("R2").Select
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=True
Application.CutCopyMode = False
'
' Trim Values
'
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Dim Cell As Range
'Also Treat CHR 0160, as a space (CHR 032)
Selection.Replace what:=Chr(160), Replacement:=Chr(32), _
LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:=False
'Trim in Excel removes extra internal spaces, VBA does not
On Error Resume Next 'in case no text cells in selection
For Each Cell In Intersect(Selection, _
Selection.SpecialCells(xlConstants, xlTextValues))
Cell.Value = Application.Trim(Cell.Value)
Next Cell
On Error GoTo 0
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
'
' Deliminate Rows to Columns
'
Selection.TextToColumns Destination:=Range("R2"), DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=True, Tab:=False, _
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)) _
, TrailingMinusNumbers:=True
Range("R1", "AAA1").Clear
Range("R2").Select
End Sub