How to close all the excel file open - excel

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.

Related

Run Complicated Macro on Many Files

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

code take more than 10 minutes to be executed

I use the following code to import text file tab delimiter, and use for loop for more than one million row, to modify some range("AF") with caller ID, but the problem it takes more than 10 minutes to finish and open the excel with the result.
So any suggestion to speed up the following code,
Public Function txtimport() As Integer
Dim b1 As Workbook, s As String, J As Long
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
s = Application.GetOpenFilename()
If s = "False" Then
txtimport = 1
GoTo Nofile
Else
txtimport = 0
End If
Close #1
Open s For Input As #1
J = 1
Workbooks.OpenText Filename:=s, Origin:= _
437, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False _
, 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), Array(9, 2), _
Array(10, 2), Array(11, 2), Array(12, 2), Array(13, 2), Array(14, 2), Array(15, 2), Array( _
16, 2), Array(17, 2), Array(18, 2), Array(19, 2), Array(20, 2), Array(21, 2), Array(22, 2), _
Array(23, 2), Array(24, 2), Array(25, 2), Array(26, 2), Array(27, 2), Array(28, 2), Array( _
29, 2), Array(30, 2), Array(31, 2), Array(32, 2), Array(33, 2), Array(34, 2), Array(35, 2), _
Array(36, 2), Array(37, 2), Array(38, 2), Array(39, 2), Array(40, 2), Array(41, 2), Array( _
42, 2), Array(43, 2), Array(44, 2), Array(45, 2), Array(46, 2), Array(47, 2)), _
TrailingMinusNumbers:=True
Close #1
Nofile:
End Function
Sub caller_id()
Dim caller_id As String
Dim parent_id, child_id As Long
Dim parent As Range
Dim LastRow, r, x As Long
LastRow = Range("A1").End(xlDown).Row
Columns("AF:AF").NumberFormat = "#"
For r = 2 To LastRow
If Range("AF" & r).Value <> "" And Range("C" & r) <> "0" Then
caller_id = Range("AF" & r).Value
child_id = Range("C" & r).Value
Set parent = Range("B:B").Find(child_id)
If parent Is Nothing Then
Else
x = parent.Row
Range("AF" & x).Value = caller_id
End If
End If
Next r
End Sub
Private Sub Workbook_Open()
Dim y As Integer
y = txtimport
If y = 0 Then
Call caller_id
End If
End Sub

How to format date when converting text to columns?

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

how to get field width info of the excel text to column

While converting text to column using excel wizard. how to get the field info array used in this conversion. for example in the vba code generated in a sample text to column, how can we procure the fieldinfo array used
Array(0, 1), Array(24, 1), Array(44, 1) etc. preferably in a variable
Selection.TextToColumns Destination:=Range("A5"), DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 1), Array(24, 1), Array(44, 1), Array(70, 1), Array(79, 1), _
Array(96, 1), Array(107, 1), Array(118, 1), Array(127, 1), Array(135, 1)), _
TrailingMinusNumbers:=True
Like this?
Dim fldInfo
fldInfo = Array(Array(0, 1), Array(24, 1), Array(44, 1), Array(70, 1), Array(79, 1), _
Array(96, 1), Array(107, 1), Array(118, 1), Array(127, 1), Array(135, 1))
Selection.TextToColumns Destination:=Range("A5"), DataType:=xlFixedWidth, _
FieldInfo:=fldInfo, TrailingMinusNumbers:=True

Dynamic Destination VBA

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

Resources