VBA - Flat Text Import Changes - excel

We have a mission critical spreadsheet that imports a lot of flat text from a desgin program and then brings it in to this spreadsheet.
We recently updated the design software, which we do once a year and have done so in my 12 years here. This year, they made a change to a file where it placed the header of a column of text in a different place. Now, our program will not import it correctly. It is the PART column...
Old text file:
New Text File...
So as you can see, they moved PART to the lower left.
Not being an expert in VBA, I am struggling to find exactly where I need to modify the code to bring it in properly..
This is the section of VBA code where I do think the selections are made but nothing specifies PART in the code...perhaps it is part of the Array? The file is called CZE_DET.OUT.
Sub IMPORT_CZEOUT()
Dim aryJobs() As String
Dim strComb As String
Dim strDir As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
Sheets("CEE ORDER").Visible = True
Sheets("CZE_DET").Visible = True
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Sheets("CEE ORDER").Select
For i = 1 To colAllBuildings.Count
strDir = Dir$(colAllBuildings.Item(i) & "\CZE_DET.OUT")
If strDir <> "" Then
Workbooks.OpenText Filename:=colAllBuildings.Item(i) & "\CZE_DET.OUT", Origin:=xlWindows, _
StartRow:=7, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(5, 1), Array(9, 9), Array(10, 1), _
Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(18, 1), _
Array(28, 9), Array(35, 9), Array(47, 9), Array(54, 1), Array(57, 1), _
Array(62, 1), Array(67, 1), Array(72, 1))
Range("A1:L" & CStr(Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row)).Select
Selection.Copy
Windows(strShipperName).Activate ' This line does not work, for NO reason!
' Windows(1).ActivatePrevious
Sheets("CZE_DET").Select
Range("A1").Select
If Range("A1").Value <> "" Then
ActiveSheet.Range("A65536").End(xlUp).Select
ActiveCell.Offset(1, 0).Select
End If
Selection.PasteSpecial Paste:=xlValues
Selection.Sort Key1:=Range("A12"), Order1:=xlAscending, Orientation:=xlTopToBottom
Windows("CZE_DET.OUT").Activate
ActiveWindow.Close
End If
Next
I would post the spreadsheet but it attaches the VBA though an XLA file through a network share. And the XLA file is protected and I can't seem to rename it and remove password to send a link.
I posted the entire subroutine here as I only posted where I thought t the problem would be: https://pinnaclestructures365-my.sharepoint.com/:f:/g/personal/bwolters_pinnaclestructures_com/EpGrxtGx4_BCgL4nl3QDZxcBalaRSL52pI0S8UNX0n6kOg?e=0oyh2k
Any suggestions?

Here is a re-worked example of how to make your references more explicit.
Sub IMPORT_CZEOUT()
Dim aryJobs() As String
Dim strComb As String
Dim strDir As String
Dim i As Integer, cDest As Range
Dim j As Integer, fName As String, rngData As Range, lRow As Long
Dim k As Integer, wb As Workbook, wbSrc As Workbook, wsSrc As Worksheet
Set wb = Workbooks(strShipperName) 'The wb where data is to be collected
'Include the file extension!
wb.Sheets("CEE ORDER").Visible = True
wb.Sheets("CZE_DET").Visible = True
Application.DisplayAlerts = False
Application.ScreenUpdating = False
For i = 1 To colAllBuildings.Count
fName = colAllBuildings.Item(i) & "\CZE_DET.OUT"
If Len(Dir(fName)) > 0 Then
Workbooks.OpenText Filename:=fName, Origin:=xlWindows, _
StartRow:=7, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(5, 1), Array(9, 9), Array(10, 1), _
Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(18, 1), _
Array(28, 9), Array(35, 9), Array(47, 9), Array(54, 1), Array(57, 1), _
Array(62, 1), Array(67, 1), Array(72, 1))
Set wbSrc = ActiveWorkbook 'source data workbook
Set wsSrc = wbSrc.Worksheets(1) 'source data sheet
lRow = wsSrc.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Set rngData = wsSrc.Range("A1:L" & lRow) 'all source data
With wb.Worksheets("CZE_DET") 'EDIT
Set cDest = .Cells(.Rows.Count, "A").End(xlUp)
End With
If Len(cDest.Value) > 0 Then Set cDest = cDest.Offset(1)
cDest.Resize(rngData.Rows.Count, rngData.Columns.Count).Value = rngData.Value
'not sure about this line....
Selection.Sort Key1:=Range("A12"), Order1:=xlAscending, Orientation:=xlTopToBottom
wbSrc.Close savechanges:=False 'close the source file
End If
Next
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
EDIT - as pointed out in a comment, the length of one of the fileds has increased by 1 character, so the FieldInfo argument needs to be updated:
Workbooks.OpenText Filename:=fName, Origin:=xlWindows, _
StartRow:=7, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(5, 1), Array(9, 9), Array(10, 1), _
Array(13, 9), Array(14, 1), Array(15, 9), Array(16, 1), Array(18, 1), _
Array(28, 9), Array(35, 9), Array(47, 9), Array(55, 1), Array(58, 1), _
Array(63, 1), Array(68, 1), Array(73, 1))

The open statement could be simplified as the skipped fields (type=9) are the blanks and values are trimmed on import.
Workbooks.OpenText Filename:=s, Origin:=xlWindows, _
StartRow:=7, DataType:=xlFixedWidth, _
FieldInfo:=Array(Array(0, 9), Array(4, 1), Array(18, 1), Array(27, 1), _
Array(35, 1), Array(54, 1), Array(58, 1), _
Array(63, 1), Array(68, 1), Array(73, 1))
Tested with this text file
line 1
line 2
line 3
line 4
line 5
line 6
ish description part punch comment qnt feet inch 16th mark
--- ------------- -------- ------- ------------------ --- ---- ---- ---- ------
xxx 8.0x3.5 c 12 8x35c12 psu-psu see drawing ec-1 28 16 8 3 ec-1
xxx 8.0x3.5 c 12 8x35c12 psu-psu see drawing ec-1 28 16 8 3 ec-1
xxx 8.0x3.5 c 12 8x35c12 psu-psu see drawing ec-1 28 16 8 3 ec-1
a-z a-----------z a----- z a-----z a----------------z a-z a--z a--z a--z a----z

Related

open txt files with VBA which meet date criteria naming convention includes date

I am using software which generates a logfile everyday, and my technicians need to check the logs and I want to make it as easy as possible, I have a script that was used previously, where the techs enter the first and last date in cells M2 and O2 these dates are then converted to the format which corresponds to the file name:
Sheets("Intake reports").Select
Range("M2").Select 'Get date of 1st day
BCDate = ActiveCell
Application.ScreenUpdating = False
BCday = Left(BCDate, 2)
BCmonth = Mid(BCDate, 4, 2)
BCyear = Right(BCDate, 2)
BCDate1st = BCyear + BCmonth + BCday
Range("O2").Select 'Get date of 2nd day
BCDate = ActiveCell
Application.ScreenUpdating = False
BCday = Left(BCDate, 2)
BCmonth = Mid(BCDate, 4, 2)
BCyear = Right(BCDate, 2)
BCDate2nd = BCyear + BCmonth + BCday
Application.DisplayAlerts = False
Then it opens the two files and copies them into a worksheet:
'Load 1st BC log file
'
Workbooks.OpenText Filename:="C:\Users\1548013\Desktop\Logfiles\BC" + BCDate1st + ".LOG", Origin:= _
xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote _
, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:= _
False, Space:=False, 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), 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)), TrailingMinusNumbers:=True
LastRow1st = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
'Selection.SpecialCells(xlCellTypeLastCell).Select Line 1 of 2
'TheLastRow = ActiveCell.Row Line 2 of 2
Range("a1:x" & LastRow1st).Select
Selection.Copy
' Windows("Log Template.xlsm").Activate
Windows("filename.xlsm").Activate
Sheets("LogTemplate").Select
Range("A1").Select
ActiveSheet.Paste
Windows("BC" + BCDate1st + ".LOG").Activate
ActiveWindow.Close
Application.DisplayAlerts = False
' Workbooks.OpenText Filename:="I:\KMcK\LogFiles\BC" + BCDate2nd + ".LOG", Origin:=
'Load 2nd BC log file
Workbooks.OpenText Filename:="C:\Users\1548013\Desktop\Logfiles\BC" + BCDate2nd + ".LOG", Origin:= _
xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote _
, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:= _
False, Space:=False, 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), 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)), TrailingMinusNumbers:=True
LastRow2nd = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Row
Range("a1:x" & LastRow2nd).Select
Selection.Copy
Windows("filename").Activate
' Windows("filename").Activate
Sheets("LogTemplate").Select
Range("A" & LastRow1st + 1).Select
ActiveSheet.Paste
Windows("BC" + BCDate2nd + ".LOG").Activate
ActiveWindow.Close
This only works for two consecutive days, as each day is a separate file. I would like to enter the start date of the study in M2 and today's date in o2 and the script opens and imports every file between the two dates (inclusive).
thanks in advance
Option Explicit
Sub IntakeReports()
Const FOLDER = "C:\Users\1548013\Desktop\Logfiles\" '
Dim wb As Workbook
Dim rngSrc As Range, rngTarget As Range
Dim dtFirst As Date, dtLast As Date, dt As Date
Dim n As Long, i As Long
Dim logfile As String, msg As String
Set wb = ThisWorkbook
With wb.Sheets("IntakeReports")
dtFirst = .Range("M2").Value2
dtLast = Now
End With
n = DateDiff("d", dtFirst, dtLast) + 1
If n < 1 Then
MsgBox "End date must be after start date", vbCritical
Exit Sub
Else
msg = Format(dtFirst, "dd-mmm-yy") & " to " & _
Format(dtLast, "dd-mmm-yy") & vbLf & _
vbLf & "Read " & n & " reports ?"
If vbNo = MsgBox(msg, vbYesNo, "Confirm") Then
Exit Sub
End If
msg = ""
End If
' select report folder
Dim fso As Object, sFolder As String
Set fso = CreateObject("Scripting.FileSystemObject")
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Please select a folder"
.InitialFileName = FOLDER
.Show
.AllowMultiSelect = False
If .SelectedItems.Count = 0 Then 'If no folder is selected, abort
MsgBox "You did not select a folder"
Exit Sub
End If
sFolder = .SelectedItems(1) 'Assign selected folder to ParentFolder
End With
If Right(sFolder, 1) <> "\" Then sFolder = sFolder & "\"
' target cell for copy
Set rngTarget = wb.Sheets("LogTemplate").Range("A1")
' loop though dates
Application.ScreenUpdating = False
n = 0
For dt = dtFirst To dtLast
logfile = "BC" & Format(dt, "yymmdd") & ".LOG"
' check file exists
If fso.FileExists(sFolder & logfile) Then
Workbooks.OpenText Filename:=sFolder & logfile, Origin:= _
xlMSDOS, StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote _
, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:= _
False, Space:=False, 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), 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)), TrailingMinusNumbers:=True
With ActiveWorkbook
Set rngSrc = .Sheets(1).UsedRange
rngSrc.Copy rngTarget
Set rngTarget = rngTarget.Offset(rngSrc.Rows.Count)
.Close
End With
i = i + 1
Else
n = n + 1
msg = msg & vbLf & logfile
End If
Next
Application.ScreenUpdating = True
' result
If n > 0 Then msg = vbLf & n & " logs not found" & msg
msg = i & " logs found" & msg
MsgBox msg, vbInformation, sFolder
End Sub

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

Run vba for multiple selected Excel file

I have a code to open text files to copy included data and paste it in the excel file, but while select multiple files the code run only for one file and i want to run it for all selectet files
CWB is the main file
NWB is the file to copy from it
The code
Sub Import_Reports()
' Difine References
Dim CWB As Excel.Workbook
Dim NWB As Excel.Workbook
Dim FN As String
Dim FD As FileDialog
Set CWB = ThisWorkbook
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.AllowMultiSelect = True
.Filters.Add "Excel Files or Text or CSV", "*.xls; *.xlsx; *.xlsm; *.xlsb; *.csv; *.txt", 1
.Show
If .SelectedItems.Count > 0 Then
FN = .SelectedItems(1)
Workbooks.OpenText Filename:=FN, _
Origin:=65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 2), _
Array(2, 2), Array(3, 2), Array(4, 4), Array(5, 1), Array(6, 2), Array(7, 2), Array(8, 2), _
Array(9, 4), Array(10, 1), Array(11, 1), Array(12, 4), Array(13, 2), Array(14, 2), Array(15 _
, 1), Array(16, 1), Array(17, 4), Array(18, 4), Array(19, 1), Array(20, 1), Array(21, 1), _
Array(22, 1)), TrailingMinusNumbers:=True
Set NWB = ActiveWorkbook
NWB.Activate
ActiveSheet.Select
Dim LastRow As Long
LastRow = Range("B" & Rows.Count).End(xlUp).Row
Range("A2:V" & LastRow).Select
Selection.Copy
CWB.Activate
Sheets("Payroll Report").Select
LastRow = Range("B" & Rows.Count).End(xlUp).Row + 1
Range("A" & LastRow).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
Cells.Select
Selection.SpecialCells(xlCellTypeLastCell).Select
Selection.EntireRow.Delete
Range("A" & LastRow).Select
NWB.Close SaveChanges:=False
Else
Exit Sub
End If
End With
End Sub
Move the copying code to a separate subroutine that you can call for each file.
Option Explicit
Sub Import_Reports()
' Define References
Dim CWB As Excel.Workbook
Dim FD As FileDialog, n
Set CWB = ThisWorkbook
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.AllowMultiSelect = True
.Filters.Add "Excel Files or Text or CSV", "*.xls; *.xlsx; *.xlsm; *.xlsb; *.csv; *.txt", 1
.Show
If .SelectedItems.Count = 0 Then Exit Sub
For n = 1 To .SelectedItems.Count
Call ImportTextFile(CWB, .SelectedItems(n))
Next
End With
MsgBox n - 1 & " files imported", vbInformation
End Sub
Sub ImportTextFile(CWB As Workbook, filename As String)
Workbooks.OpenText filename:=filename, _
Origin:=65001, StartRow:=1, DataType:=xlDelimited, TextQualifier:= _
xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, _
Comma:=True, Space:=False, Other:=False, FieldInfo:=Array(Array(1, 2), _
Array(2, 2), Array(3, 2), Array(4, 4), Array(5, 1), Array(6, 2), Array(7, 2), Array(8, 2), _
Array(9, 4), Array(10, 1), Array(11, 1), Array(12, 4), Array(13, 2), Array(14, 2), Array(15 _
, 1), Array(16, 1), Array(17, 4), Array(18, 4), Array(19, 1), Array(20, 1), Array(21, 1), _
Array(22, 1)), TrailingMinusNumbers:=True
Dim LastRow As Long, ar
With ActiveWorkbook.Sheets(1)
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row
' copy values to array except last row
ar = .Range("A2:V" & LastRow - 1).Value2
End With
ActiveWorkbook.Close SaveChanges:=False
' copy array to CWB
With CWB.Sheets("Payroll Report")
LastRow = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & LastRow).Resize(UBound(ar), UBound(ar, 2)) = ar
End With
End Sub
Import Text Files
Option Explicit
Sub Import_Reports()
Dim FD As FileDialog
Set FD = Application.FileDialog(msoFileDialogFilePicker)
Dim collFilePaths As Object
With FD
.AllowMultiSelect = True
.Filters.Add "Excel Files or Text or CSV", "*.xls; *.xlsx; *.xlsm; *.xlsb; *.csv; *.txt", 1
.Show
If .SelectedItems.Count = 0 Then
MsgBox "You canceled.", vbExclamation
Exit Sub
Else
Set collFilePaths = .SelectedItems
End If
End With
Dim CWB As Workbook: Set CWB = ThisWorkbook
Dim cws As Worksheet: Set cws = CWB.Worksheets("Payroll Report")
Dim cfrrg As Range
Set cfrrg = cws.Range("B" & cws.Rows.Count).End(xlUp) _
.Offset(1).EntireRow.Columns("A:V")
Application.ScreenUpdating = False
Dim FilePath As Variant
Dim NWB As Workbook
Dim nws As Worksheet
Dim nrg As Range
Dim nLastRow As Long
Dim crg As Range
For Each FilePath In collFilePaths
'Set NWB = Workbooks.Open(FilePath) ' tested with this line
On Error Resume Next
Set NWB = Workbooks.OpenText(Filename:=CStr(FilePath), _
Origin:=65001, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=True, Semicolon:=False, Comma:=True, Space:=False, _
Other:=False, FieldInfo:=Array(Array(1, 2), Array(2, 2), _
Array(3, 2), Array(4, 4), Array(5, 1), Array(6, 2), _
Array(7, 2), Array(8, 2), Array(9, 4), Array(10, 1), _
Array(11, 1), Array(12, 4), Array(13, 2), Array(14, 2), _
Array(15, 1), Array(16, 1), Array(17, 4), Array(18, 4), _
Array(19, 1), Array(20, 1), Array(21, 1), Array(22, 1)), _
TrailingMinusNumbers:=True)
On Error GoTo 0
If Not NWB Is Nothing Then
Set nws = NWB.Worksheets(1)
' Delete last row = Don't Copy Last row - '- 1' ???
nLastRow = nws.Range("B" & nws.Rows.Count).End(xlUp).Row - 1
If nLastRow >= 2 Then
Set nrg = nws.Range("A2:V" & nLastRow)
nLastRow = nLastRow - 1
Set crg = cfrrg.Resize(nLastRow)
crg.Value = nrg.Value
Set cfrrg = cfrrg.Offset(nLastRow)
End If
NWB.Close SaveChanges:=False
Set NWB = Nothing
End If
Next FilePath
cws.Activate
cfrrg.Cells(1).Select
'CWB.Save
Application.ScreenUpdating = True
MsgBox "Reports imported.", vbInformation
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

Runtime error using range with variable name in it

I am getting a runtime error 1004: Method 'Range' of object '_Global' failed when running my code. It should be splitting the data in the source column into a destination specified by the first blank column in the array. Because the source data is erratically formatted it needs to look for tabs or line breaks as the delimiter. I am using variable names for the source and blank columns as they are not at a fixed position in the array.
Dim CurrentCol As Integer
Dim FirstCol As Integer
Dim LastCol As Integer
Dim ColName As String
Dim BlankCol As Integer
Dim Source As Range
Dim SourceCol As String
Dim SourceAdd As String
Dim FirstColName As String
BlankCol = ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column + 1
FirstCol = BlankCol + 1
Cells(1, FirstCol).Value = "FirstCol"
FirstColName = Cells(1, FirstCol).Value
Cells(1, BlankCol).Value = "Unique Classes"
Set Source = ActiveSheet.Rows(1).Find("International", LookIn:=xlValues)
SourceCol = Source.Column
SourceAdd = Source.Address
Range(SourceAdd).EntireColumn.TextToColumns _
Destination:=Range("PatBase[[#Headers], [" & FirstColName & "]]"), _
DataType:=xlDelimited, _
Tab:=True, Other:=True, OtherChar:="" & Chr(10) & "",_
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)), _
TrailingMinusNumbers:=True
Once the data is in the columns I then have more code which truncates it to 4 characters with the range in the same format, but this is working fine:
CurrentCol = FirstCol
For i = FirstCol To LastCol
Columns(CurrentCol).Select
ColName = Cells(1, CurrentCol).Value
If ColName = "" Then
Exit For
End If
Selection.TextToColumns Destination:=Range("PatBase[[#Headers], [" & ColName & "]]"), _
DataType:=xlFixedWidth, FieldInfo:=Array(Array(0, 1), Array(4, 9)), _
TrailingMinusNumbers:=True
CurrentCol = CurrentCol + 1
Next i
I suspect I am missing something obvious but I'm not a skilled macro writer so am at a loss. Can anyone help?

Resources