VBA replacement for Application.FileSearch

R

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
 

Excel Facts

Did you know Excel offers Filter by Selection?
Add the AutoFilter icon to the Quick Access Toolbar. Select a cell containing Apple, click AutoFilter, and you will get all rows with Apple
Sort by date Sort by votes
You must log in or register to reply here.

Similar threads

J
  • Question
Cannot close temporary file and delete in VBA for Excel coding
Replies
2
Views
500
jolor69
J
B
  • Solved
Getting Macros to run automatically
Replies
3
Views
205
mumps
mumps
M
  • Solved
Replacing delete with a value
Replies
3
Views
151
Alex Blakenburg
A
B
  • Solved
VBA Help - Same Function needed for multiple sheets
Replies
2
Views
241
birdman15
B
N
  • Question
My code is suddenly really slow
Replies
1
Views
132
RobP
R

Forum statistics

Threads
1,214,782
Messages
6,121,532
Members
449,037
Latest member
tmmotairi

Share this page

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
Back
Top