Solutionn required for application.filesearch

N

naveen madhava

New Member
Joined
Apr 8, 2011
Messages
2
Hi friends,
I am very new to excel vb. I have an application which was built using excel2003 version. However, a piece of code related to application.filesearch method is not working in my office version 2007:confused:. I have looked at various solutions, however due to lack of experience I am unable to incorporate the changes.:eeek: Any help in this regard is much appreciated. I am posting the entire code in here.

Thanks,
N

Option Explicit
Sub Import()
' Declare variables
Dim varFName As Variant ' Input Filename
Dim lngRN As Long ' Row number for placing input on sheets
Dim arrSpl() As String ' Array for holding input data
Dim intFlds As Integer ' Number of fields in input record
Dim intFC As Integer ' Loop counter for field placement loop
Dim strInput As String ' Line input string
Dim strReg As String ' Region name
Dim blNS As Boolean ' New sheet indicator
Dim strRN As String ' For lookup range name
Dim arrReg() As Variant ' Array for storing LDZNames
Dim strRegco As String ' Short code for region
Dim intLC As Integer ' Loop Counter
Dim strRegName As String
Dim strRegCode As String
Dim intOS As Integer
Dim strGTMSDir As String
Dim strGTMSDrv As String
Dim strCurDrv As String
' Set new sheet flag to false
blNS = False
' Set up array to hold LDZTable
arrReg() = Range("LDZTable").Value
' Set up Region Name and Code
strRegCode = arrReg(2, 1)
strRegName = arrReg(2, 2)
' MsgBox "strREgcode: " & strRegCode
' MsgBox "strRegName : " & strRegName
strGTMSDir = arrReg(2, 3)
strGTMSDrv = Left(strGTMSDir, 1)
' MsgBox "strGTMSDir : " & strGTMSDir
' MsgBox "strGTMSDrv : " & strGTMSDrv
strReg = Replace(strRegName, "_", " ", , , vbTextCompare)
' Delete Old Files
' DelOldFiles (strGTMSDir)

Dim strAFname() As Variant ' Array to hold filenames and creation dates
Dim strPath As String ' Path of files
Dim strFT As String ' File type
Dim strFname As String ' File name
Dim intFN As Integer ' File number counter
Dim intNF As Integer ' Number of files
' Dim intLC As Integer ' Loop counter
Dim intMax As Integer ' Max date
Dim strFFName As String ' Full file name
' Set path for this workbook and add \
' strPath = ThisWorkbook.Path & "\"
strPath = strGTMSDir 'strGD
' Set definition for filenames
strFT = "NO47*.*"
' Search directory for files and set count of files
With Application.FileSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = False
.Filename = strFT
.MatchTextExactly = False
.Execute (msoSortByLastModified)
intNF = .FoundFiles.Count
End With
If intNF = 0 Then
MsgBox "No files available"
Sheets("Filedate").Select
Cells(1, 1) = 1
Exit Sub
End If
intNF = 1
Exit Sub

' Redim array to hold file names and times
ReDim strAFname(2, intNF)
' Set file number to zero
intFN = 0
' Add file type to Path
strPath = strGTMSDir & strFT ' strGD & strFT
' Execute DIR
strFname = Dir(strPath)
' Add path to result of DIR
strFFName = strGTMSDir & strFname ' strGD & strFname
' Put filename in array field 1 and put creation date time in field 2
' Execute DIR again and loop if file found
' Start of modifications by gpc 26th Aug 05 **********************
Sheets("Filedate").Select
Range("A1:A50").Select
Selection.ClearContents
Do
intFN = intFN + 1
strAFname(1, intFN) = strFname
strFFName = strGTMSDir & strFname
Cells(intFN, 1) = FileDateTime(strFFName)
strFname = Dir
Loop While strFname <> ""
intMax = 0
For intLC = 1 To intNF
strAFname(2, intLC) = Cells(intLC, 4)
If strAFname(2, intLC) < 0.5 Then

Kill strGTMSDir & strAFname(1, intLC)
Else
intMax = intLC
End If
Next intLC
If intMax = 0 Then
MsgBox "No current file available"
Cells(1, 1) = 1
Exit Sub
End If
' End of modifications by gpc 26th Aug 05 ***********************
varFName = strAFname(1, intMax)
' Delete import sheet
Application.DisplayAlerts = False
On Error Resume Next
Sheets(strRegName).Delete
On Error GoTo 0
Application.DisplayAlerts = True
' Turn off auto calculation
Application.Calculation = xlCalculationManual
' Present user with FileOpen dialog
strCurDrv = Left(ThisWorkbook.Path, 1)
ChDrive strGTMSDrv
ChDir strGTMSDir
' varFName = Application.GetOpenFilename("TTF Files (*.*), *.*", , "Select Interruptions File")
ChDrive strCurDrv
ChDir ThisWorkbook.Path
' Exit routine if no file selected
If varFName = False Then
MsgBox "No file selected"
Exit Sub
End If
' Turn off screen updating
Application.ScreenUpdating = False
' Open file selected by user
Open strGTMSDir & varFName For Input As #1
' Loop through data a line at a time until end of file
Do While Not EOF(1)
Line Input #1, strInput
' Split data line into fields
arrSpl = Split(strInput, ",", , vbTextCompare)
' Deduce number of fields in input
intFlds = UBound(arrSpl, 1)
Select Case intFlds
Case Is < 0
' No data on input line so do nothing and read next line
Case Is = 0
' One field in line which denotes region change
If strInput = strReg Then
' Add new sheet and name as region
Sheets.Add Before:=Sheets(strRegCode)
ActiveSheet.Name = Replace(strRegName, " ", "_", 1, , vbTextCompare)
' Set heading row to bold
Rows("1:1").Select
Selection.Font.FontStyle = "Bold"
' Set row counter back to 1 and set new sheet flag to true
lngRN = 1
blNS = True
Else
blNS = False
End If
Case Else
' This will be a data line so place each field in columns from column 2
' The first column is the first two fields concatenated plus a "c" where
' is present as the last character of field 3. This is done to differentiate
' what would otherwise be identical keys
If blNS Then
If Right(arrSpl(2), 2) = ":c" Then
ActiveSheet.Cells(lngRN, 1) = arrSpl(0) & arrSpl(1) & "c"
Else
ActiveSheet.Cells(lngRN, 1) = arrSpl(0) & arrSpl(1)
End If
For intFC = 1 To intFlds + 1
ActiveSheet.Cells(lngRN, intFC + 1) = arrSpl(intFC - 1)
Next intFC
' Increment row count for next record
lngRN = lngRN + 1
End If
End Select
Loop
' close file
Close #1
' Resize columns on last sheet
ActiveSheet.Range("A1").CurrentRegion.Select
Selection.Columns.AutoFit
' Define named range using sheetname and suffix
strRN = ActiveSheet.Name & "SPN"
ActiveWorkbook.Names.Add Name:=strRN, RefersTo:=Selection
' Activate region sheet
Sheets(strRegCode).Activate
' Turn on auto calculation
Application.Calculation = xlCalculationAutomatic
Range("R5:R29").Select
Selection.Copy
Range("N5").Select
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("n6").Select
intOS = Sheets(strRegCode).Cells(31, 17).Value
Selection.Offset(intOS, 0).Select
Selection.Resize(24 - intOS, Selection.Columns.Count).Select
Selection.ClearContents
Range("A1").Select
' Turn on screen updating
Application.ScreenUpdating = True
End Sub
Sub Update_TTF()
' MsgBox "in update ttf"
Sheets("Filedate").Select
If Cells(1, 1) = 1 Then
MsgBox "No current file available"
Exit Sub
End If
Sheets("NO").Select
Dim strUWBName As String
Dim strTWBName As String
Dim strRegCode As String
Dim intOSet As Integer
strRegCode = Sheets("StaticData").Cells(2, 1).Value
strUWBName = "Update_" & strRegCode & ".xls"
strTWBName = "TTF_V3_" & strRegCode & ".xls"

Application.ScreenUpdating = False
intOSet = Range("Q31").Value
' MsgBox "intOSet: " & intOSet
Range("n6").Select
Selection.Offset(intOSet, 0).Select
Selection.Resize(Selection.Rows.Count + 24 - intOSet, Selection.Columns.Count).Select

' ActiveCell.Range("A1:A45").Select
Selection.ClearContents
Range("A1").Select
ActiveWorkbook.Save
Range("C6:C29").Select
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
Worksheets("Front").Select
' Range("C7").Select
Range("PDProf").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("G5:G20").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("G6").Select
Range("NTS").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("I5:I29").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("I6").Select
Range("Take_Change").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("J6:J29").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("J7").Select
Range("Export1").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("J3").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("J4").Select
Range("EX_AF").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("M6:M29").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("M7").Select
Range("CUMTAKE").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("N5:N29").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("N6").Select
Range("Stock_Actual").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("C31:C32").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("C32").Select
Range("AV_TO_INT").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("D33").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("D34").Select
Range("LargeFirm").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("H31:H33").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("H32").Select
Range("Min_Holder").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("L1").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("P2").Select
Range("DAYDATE").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("D34:D35").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("D35").Select
Range("FirmVLDMC").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("G35").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("G36").Select
Range("H35").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("I34").Select
Application.CutCopyMode = False
Selection.Copy
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("I35").Select
Range("Max_Stock").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
' Windows("UpdateEast_EA.xls").Activate
Windows(strUWBName).Activate
Range("K31").Select
Selection.Copy
Application.ScreenUpdating = True
' Windows("TtfgcV2_EA.xls").Activate
Windows(strTWBName).Activate
' Range("K32").Select
Range("LDZNAME").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Windows(strUWBName).Activate
Range("L5:L29").Select
Selection.Copy
Application.ScreenUpdating = True
Windows(strTWBName).Activate
Range("LP_stockgc").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Range("AX5:AX29").Select
Selection.Copy
Range("Q5").Select
Selection.PasteSpecial Paste:=xlFormulas, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Windows(strUWBName).Activate
Range("K6:K29").Select
Selection.Copy
Application.ScreenUpdating = True
Windows(strTWBName).Activate
Range("IMPORTS").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False

Windows(strUWBName).Activate
Range("H6:H29").Select
Selection.Copy
Application.ScreenUpdating = True
Windows(strTWBName).Activate
Range("EXPORTO").Select
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("H5").Select
ActiveSheet.Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Application.ScreenUpdating = True
'ThisWorkbook.Close SaveChanges:=True
End Sub
'Sub View_TTF()
'
' Dim strTTFWBName As String
'
' strTTFWBName = "TTF_V3_" & Sheets("StaticData").Cells(2, 1).Value & ".xls"
' Workbooks(strTTFWBName).Activate
'
'End Sub
 

Excel Facts

Bring active cell back into view
Start at A1 and select to A9999 while writing a formula, you can't see A1 anymore. Press Ctrl+Backspace to bring active cell into view.
Sort by date Sort by votes
Weclome to the Forum,

File Search has certainly been removed from 2007 so you may have to use Dir (Directory) command instead.

Here is an example for you

Code: 
[SIZE=2]
[COLOR=green]'Change path to your path[/COLOR]
Sub Samplex1()
Dim strFilename As String
Dim strPath As String
Dim wbkTemp As Workbook

strPath = "[COLOR=green]C:\Access VBA Practice\[/COLOR]"
strFilename = Dir(strPath & Range("a1").Value & "*.xls")
Do While Len(strFilename) > 0
Set wbkTemp = Workbooks.Open(strPath & strFilename)
[COLOR=green]'[/COLOR]
[COLOR=green]' do your code with the workbook[/COLOR]
[COLOR=green]'[/COLOR]
[COLOR=green][/COLOR]
[COLOR=green]' save and close it[/COLOR]
[COLOR=green]'wbkTemp.Close True[/COLOR]

strFilename = Dir
Loop

End Sub
[/SIZE]
 
Upvote 0
You must log in or register to reply here.

Similar threads

willow1985
  • Solved
VBA Run-time error 91 - Object variable or With block variable not set when trying to refresh data/Sleep
Replies
4
Views
390
willow1985
willow1985
D
  • Solved
extract to another workbook and save using desktop path
2
Replies
12
Views
205
jolivanes
jolivanes
S
  • Question Question
Macro Formatting to all WS
Replies
4
Views
341
MARK858
MARK858
C
  • Solved
Please help me clean up my VBA script, I'm having trouble with redundancies
Replies
4
Views
449
CapRavOr
C
K
  • Question Question
Increasing row before the macro runs again
Replies
1
Views
229
kbk
K

Forum statistics

Threads
1,224,594
Messages
6,179,794
Members
452,943
Latest member
Newbie4296

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