S
SHAWTY721
Option Explicit
Sub ImportInventoryData()
Dim FS As FileSearch
Dim FilePath, jane As String, FileSpec As String
Dim i As Integer
' Select directory:
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Select the Directory for Inventory Files to Import:"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Cancelled - No Directory Selected"
FilePath = ""
FileSpec = ""
Exit Sub
Else
FilePath = .SelectedItems(1)
FileSpec = "*.dat"
End If
End With
' Create a FileSearch object:
Set FS = Application.FileSearch
With FS
.LookIn = FilePath
.Filename = FileSpec
.Execute
' Exit if no files are found
If .FoundFiles.Count = 0 Then
MsgBox "No files were found at:'" & vbCrLf & FilePath & "'"
Exit Sub
End If
End With
' Import Inventory data for each *.dat file found:
Dim FName As String, UnitName As String, Sep As String
Dim RowNdx As Integer
Dim ColNdx As Integer
Dim TempVal As Variant
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim SaveColNdx As Integer
Dim FileCode As String
Application.Cursor = xlWait
Application.ScreenUpdating = False
For i = 1 To FS.FoundFiles.Count
FName = FS.FoundFiles(i)
' Application.ScreenUpdating = True
Application.StatusBar = "Processing Dat File: " & FName
' Application.ScreenUpdating = False
Sep = Chr(9)
Workbooks.Open Filename:=ThisWorkbook.Path & "\Inventory Template.xls"
Sheets("Inventory Data").Select
Range("A2").Select
SaveColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row - 1
Open FName For Input Access Read As #1
Do While Not EOF(1)
Line Input #1, WholeLine
If RowNdx > 1 Then
If Right(WholeLine, 1) <> Sep Then
WholeLine = WholeLine & Sep
End If
ColNdx = SaveColNdx
Pos = 1
NextPos = InStr(Pos, WholeLine, Sep)
Do While NextPos >= 1
TempVal = Mid(WholeLine, Pos, NextPos - Pos)
Cells(RowNdx, ColNdx).Value = Replace(TempVal, Chr(34), "")
Pos = NextPos + 1
ColNdx = ColNdx + 1
NextPos = InStr(Pos, WholeLine, Sep)
Loop
End If
RowNdx = RowNdx + 1
Loop
Range("A2").Select
Close #1
' Resize columns:
Selection.CurrentRegion.Select
Selection.Columns.EntireColumn.AutoFit
Range("A2").Select
Sheets("Inventory Data").Range("A1").CurrentRegion.Name = "DataRange"
' Refresh Pivot Tables (only need to refresh first pivot table - others
use it as source)
Sheets("By Vendor").PivotTables(1).PivotCache.Refresh
' Save data in template
If Len(Dir(FilePath & "\Output", vbDirectory)) = 0 Then
MkDir FilePath & "\Output"
End If
FileCode = Mid(FName, Len(FilePath) + 1, Len(FName) - Len(FilePath) - 4)
If ThisWorkbook.Worksheets("Macro Data").Range("C:C").Find(FileCode,
LookAt:=xlPart) Is Nothing Then
UnitName = FileCode
Else
UnitName = Application.WorksheetFunction.VLookup(FileCode, _
ThisWorkbook.Worksheets("Macro Data").Range("C"), 2, 0)
End If
jane = FilePath & "\Output\" & UnitName & " - " & _
Format(Workbooks("Inventory Macro.xls").Worksheets("Macro
Data").Range("a2"), "MM-YY")
' it's here ----------------------------V
ActiveWorkbook.SaveAs Filename:=FilePath & "Output\" & UnitName & " - "
& _
Format(Workbooks("Inventory Macro.xls").Worksheets("Macro
Data").Range("a2"), "MM-YY"), _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Next i
ErrorHandler:
If Err <> 0 Then MsgBox "Import Process Aborted"
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Application.StatusBar = False
On Error GoTo 0
End Sub
Sub ImportInventoryData()
Dim FS As FileSearch
Dim FilePath, jane As String, FileSpec As String
Dim i As Integer
' Select directory:
With Application.FileDialog(msoFileDialogFolderPicker)
.InitialFileName = ThisWorkbook.Path & "\"
.Title = "Select the Directory for Inventory Files to Import:"
.Show
If .SelectedItems.Count = 0 Then
MsgBox "Cancelled - No Directory Selected"
FilePath = ""
FileSpec = ""
Exit Sub
Else
FilePath = .SelectedItems(1)
FileSpec = "*.dat"
End If
End With
' Create a FileSearch object:
Set FS = Application.FileSearch
With FS
.LookIn = FilePath
.Filename = FileSpec
.Execute
' Exit if no files are found
If .FoundFiles.Count = 0 Then
MsgBox "No files were found at:'" & vbCrLf & FilePath & "'"
Exit Sub
End If
End With
' Import Inventory data for each *.dat file found:
Dim FName As String, UnitName As String, Sep As String
Dim RowNdx As Integer
Dim ColNdx As Integer
Dim TempVal As Variant
Dim WholeLine As String
Dim Pos As Integer
Dim NextPos As Integer
Dim SaveColNdx As Integer
Dim FileCode As String
Application.Cursor = xlWait
Application.ScreenUpdating = False
For i = 1 To FS.FoundFiles.Count
FName = FS.FoundFiles(i)
' Application.ScreenUpdating = True
Application.StatusBar = "Processing Dat File: " & FName
' Application.ScreenUpdating = False
Sep = Chr(9)
Workbooks.Open Filename:=ThisWorkbook.Path & "\Inventory Template.xls"
Sheets("Inventory Data").Select
Range("A2").Select
SaveColNdx = ActiveCell.Column
RowNdx = ActiveCell.Row - 1
Open FName For Input Access Read As #1
Do While Not EOF(1)
Line Input #1, WholeLine
If RowNdx > 1 Then
If Right(WholeLine, 1) <> Sep Then
WholeLine = WholeLine & Sep
End If
ColNdx = SaveColNdx
Pos = 1
NextPos = InStr(Pos, WholeLine, Sep)
Do While NextPos >= 1
TempVal = Mid(WholeLine, Pos, NextPos - Pos)
Cells(RowNdx, ColNdx).Value = Replace(TempVal, Chr(34), "")
Pos = NextPos + 1
ColNdx = ColNdx + 1
NextPos = InStr(Pos, WholeLine, Sep)
Loop
End If
RowNdx = RowNdx + 1
Loop
Range("A2").Select
Close #1
' Resize columns:
Selection.CurrentRegion.Select
Selection.Columns.EntireColumn.AutoFit
Range("A2").Select
Sheets("Inventory Data").Range("A1").CurrentRegion.Name = "DataRange"
' Refresh Pivot Tables (only need to refresh first pivot table - others
use it as source)
Sheets("By Vendor").PivotTables(1).PivotCache.Refresh
' Save data in template
If Len(Dir(FilePath & "\Output", vbDirectory)) = 0 Then
MkDir FilePath & "\Output"
End If
FileCode = Mid(FName, Len(FilePath) + 1, Len(FName) - Len(FilePath) - 4)
If ThisWorkbook.Worksheets("Macro Data").Range("C:C").Find(FileCode,
LookAt:=xlPart) Is Nothing Then
UnitName = FileCode
Else
UnitName = Application.WorksheetFunction.VLookup(FileCode, _
ThisWorkbook.Worksheets("Macro Data").Range("C"), 2, 0)
End If
jane = FilePath & "\Output\" & UnitName & " - " & _
Format(Workbooks("Inventory Macro.xls").Worksheets("Macro
Data").Range("a2"), "MM-YY")
' it's here ----------------------------V
ActiveWorkbook.SaveAs Filename:=FilePath & "Output\" & UnitName & " - "
& _
Format(Workbooks("Inventory Macro.xls").Worksheets("Macro
Data").Range("a2"), "MM-YY"), _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
ActiveWorkbook.Close
Next i
ErrorHandler:
If Err <> 0 Then MsgBox "Import Process Aborted"
Application.ScreenUpdating = True
Application.Cursor = xlDefault
Application.StatusBar = False
On Error GoTo 0
End Sub