VBA replacement for Application.FileSearch

rohiiit

New Member
Joined
Apr 23, 2013
Messages
3
Can you guys please help. this is current one I am using.


Option Explicit

Public Sub CompilePOFs(sTemplatePath As String, sFolderPath As String, sEmployeePath As String, sOutputPath As String)
Dim varFile As Variant

Dim iFileCount As Integer

Dim lRowCount As Long

Dim lEmployeeCount As Long

Dim lMaxEmployees As Long

Dim wbEmpTemp As Workbook

Dim wbOutput() As Workbook

Dim wbTemp As Workbook

Dim bEmpExitFlag As Boolean
Dim bEmpFound As Boolean

Dim sPOSCodeTemp As String

Dim sTextRange As String

Dim sNumericRange As String

Dim sPivotSource As String

Dim sSaveTarget As String

Dim sModOutput As String

Dim edEmployees() As EmployeeData

Application.DisplayAlerts = False
Application.EnableEvents = False
Application.ScreenUpdating = False

Set wbEmpTemp = Workbooks.Open(Filename:=sEmployeePath, ReadOnly:=True)

Call wbEmpTemp.Sheets(1).UsedRange.Sort(Key1:=wbEmpTemp.Sheets(1).Range("E1"), Order1:=xlAscending)

lEmployeeCount = 0

For lRowCount = 2 To wbEmpTemp.Sheets(1).UsedRange.Rows.Count Step 1
If wbEmpTemp.Sheets(1).Range("A1").Offset(lRowCount - 1, 0).Value = "Global Transaction Banking" And wbEmpTemp.Sheets(1).Range("A1").Offset(lRowCount - 1, 23).Value = 1 Then
lEmployeeCount = lEmployeeCount + 1
ReDim Preserve edEmployees(1 To lEmployeeCount)
edEmployees(lEmployeeCount).EmployeeNumber = CStr(Format(wbEmpTemp.Sheets(1).Range("A1").Offset(lRowCount - 1, 1).Value, "0000000"))
edEmployees(lEmployeeCount).FirstName = wbEmpTemp.Sheets(1).Range("A1").Offset(lRowCount - 1, 2).Value
edEmployees(lEmployeeCount).LastName = wbEmpTemp.Sheets(1).Range("A1").Offset(lRowCount - 1, 3).Value
edEmployees(lEmployeeCount).Title = wbEmpTemp.Sheets(1).Range("A1").Offset(lRowCount - 1, 5).Value
edEmployees(lEmployeeCount).POSCode = wbEmpTemp.Sheets(1).Range("A1").Offset(lRowCount - 1, 4).Value
edEmployees(lEmployeeCount).Department = wbEmpTemp.Sheets(1).Range("A1").Offset(lRowCount - 1, 16).Value
edEmployees(lEmployeeCount).FullName = edEmployees(lEmployeeCount).FirstName + " " + edEmployees(lEmployeeCount).LastName
End If
Next lRowCount

lMaxEmployees = lEmployeeCount

Call wbEmpTemp.Close

Set wbEmpTemp = Nothing

iFileCount = 0

sModOutput = sOutputPath + "\" + shtConfig.Range("TIME_PERIOD").Value

Call MakeDirectory(sModOutput)

With Application.FileSearch
.NewSearch
.LookIn = sFolderPath
.SearchSubFolders = False
.Filename = ".txt"

If .Execute > 0 Then

For Each varFile In .FoundFiles
iFileCount = iFileCount + 1





ReDim Preserve wbOutput(1 To iFileCount)

'Open template file
Set wbOutput(iFileCount) = Workbooks.Open(Filename:=sTemplatePath, ReadOnly:=True)

'Open text file
Set wbTemp = Workbooks.Open(Filename:=varFile, ReadOnly:=True)

sPOSCodeTemp = Left(CStr(wbTemp.Sheets(1).Name), 10)

bEmpExitFlag = False
bEmpFound = False

lEmployeeCount = 0
Do While bEmpExitFlag = False
lEmployeeCount = lEmployeeCount + 1

If sPOSCodeTemp = edEmployees(lEmployeeCount).POSCode Then
bEmpExitFlag = True
bEmpFound = True
End If

If lEmployeeCount = lMaxEmployees Then
bEmpExitFlag = True
End If
Loop

'Parse Text to Columns
Call wbTemp.Sheets(1).UsedRange.Select
Call Application.Selection.TextToColumns(DataType:=xlDelimited, Tab:=False, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="|")
Call wbTemp.Sheets(1).UsedRange.Select

'Trimming Fix, get rid of junk headers
Call wbTemp.Sheets(1).Columns(wbTemp.Sheets(1).UsedRange.Columns.Count).Delete
Call wbTemp.Sheets(1).Columns(wbTemp.Sheets(1).UsedRange.Columns.Count).Delete
Call wbTemp.Sheets(1).Columns(wbTemp.Sheets(1).UsedRange.Columns.Count).Delete

'Getting rid of header row
Call wbTemp.Sheets(1).Rows(1).Delete

Call wbTemp.Sheets(1).UsedRange.Select

Call Application.Selection.Copy

Call wbOutput(iFileCount).Sheets(1).Paste(wbOutput(iFileCount).Sheets(1).Range("A2"))

wbOutput(iFileCount).Sheets(1).Name = sPOSCodeTemp + "_OUTPUT_PROTOTYPE"

Call wbTemp.Close(SaveChanges:=False)

sTextRange = wbOutput(iFileCount).Sheets(1).Rows(2).Columns(10).Address(False, False)
sTextRange = sTextRange + ":"
sTextRange = sTextRange + wbOutput(iFileCount).Sheets(1).Rows(wbOutput(iFileCount).Sheets(1).UsedRange.Rows.Count).Columns(wbOutput(iFileCount).Sheets(1).UsedRange.Columns.Count - 13).Address(False, False)

wbOutput(iFileCount).Sheets(1).Range(sTextRange).NumberFormat = "$#,##0.00"

sTextRange = wbOutput(iFileCount).Sheets(1).Rows(2).Columns(wbOutput(iFileCount).Sheets(1).UsedRange.Columns.Count - 13 + 1).Address(False, False)
sTextRange = sTextRange + ":"
sTextRange = sTextRange + wbOutput(iFileCount).Sheets(1).Rows(wbOutput(iFileCount).Sheets(1).UsedRange.Rows.Count).Columns(wbOutput(iFileCount).Sheets(1).UsedRange.Columns.Count).Address(False, False)

Call wbOutput(iFileCount).Sheets(1).Range(sTextRange).FillDown

Call wbOutput(iFileCount).Sheets(1).Range(sTextRange).Copy

Call wbOutput(iFileCount).Sheets(1).Range(sTextRange).PasteSpecial(xlPasteValues)

sNumericRange = "J2"
sNumericRange = sNumericRange + ":"
sNumericRange = sNumericRange + wbOutput(iFileCount).Sheets(1).Rows(wbOutput(iFileCount).Sheets(1).UsedRange.Rows.Count).Columns(wbOutput(iFileCount).Sheets(1).UsedRange.Columns.Count).Address(False, False)

Call wbOutput(iFileCount).Sheets(1).Range(sNumericRange).Columns.AutoFit
Call wbOutput(iFileCount).Sheets(1).Outline.ShowLevels(ColumnLevels:=1)

sPivotSource = wbOutput(iFileCount).Sheets(1).Name
sPivotSource = sPivotSource + "!"
sPivotSource = sPivotSource + wbOutput(iFileCount).Sheets(1).Range("A1").Address(ReferenceStyle:=xlR1C1)
sPivotSource = sPivotSource + ":"
sPivotSource = sPivotSource + wbOutput(iFileCount).Sheets(1).Rows(wbOutput(iFileCount).Sheets(1).UsedRange.Rows.Count).Columns(wbOutput(iFileCount).Sheets(1).UsedRange.Columns.Count).Address(ReferenceStyle:=xlR1C1)

wbOutput(iFileCount).PivotCaches.Add(SourceType:=xlDatabase, SourceData:=sPivotSource).CreatePivotTable _
TableDestination:="", TableName:="PivotTable1", DefaultVersion:=xlPivotTableVersion10

With wbOutput(iFileCount).Sheets(1).PivotTables("PivotTable1").PivotFields("CRM")
.Orientation = xlRowField
.Position = 1
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With

With wbOutput(iFileCount).Sheets(1).PivotTables("PivotTable1").PivotFields("CustomerName")
.Orientation = xlRowField
.Position = 2
.Subtotals = Array(False, False, False, False, False, False, False, False, False, False, False, False)
End With

wbOutput(iFileCount).Sheets(1).Name = "CUSTOMER LIST"

sSaveTarget = sModOutput + "\"

If bEmpFound = True Then
sSaveTarget = sSaveTarget + "Prototype POF - " + shtConfig.Range("TIME_PERIOD").Value + " - " + DepartmentClean(edEmployees(lEmployeeCount).Department) + " - " + edEmployees(lEmployeeCount).FullName + ".xls"
Else
sSaveTarget = sSaveTarget + "Prototype POF - " + shtConfig.Range("TIME_PERIOD").Value + " - " + sPOSCodeTemp + ".xls"
End If

Call wbOutput(iFileCount).Sheets(2).Activate
Call wbOutput(iFileCount).Sheets(2).Range("A1").Select

Call wbOutput(iFileCount).SaveAs(sSaveTarget)
Call wbOutput(iFileCount).Close
Next varFile

End If

End With

Application.DisplayAlerts = True
Application.EnableEvents = True
Application.ScreenUpdating = True


End Sub

Private Function DepartmentClean(sInput As String) As String
Dim sTemp As String

sTemp = sInput

sTemp = Replace(sTemp, "- GTB", "")
sTemp = Replace(sTemp, " Sales", "")
sTemp = Replace(sTemp, " Region", "")
sTemp = Replace(sTemp, "/", "-")
sTemp = Replace(sTemp, " ", " ")
sTemp = Replace(sTemp, " ", " ")
sTemp = Replace(sTemp, " ", " ")
sTemp = Trim(sTemp)
DepartmentClean = sTemp

End Function
 

Some videos you may like

Excel Facts

Can you sort left to right?
To sort left-to-right, use the Sort dialog box. Click Options. Choose "Sort left to right"

Watch MrExcel Video

Forum statistics

Threads
1,122,514
Messages
5,596,612
Members
414,080
Latest member
penguin23

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top