Hello everyone,
I encountered error "Object doesn't support this action" when i run the macro program after upgrade of excel (from 2003 to 2007).Upon clicking the debug button,
the highlighted line is "With Application.FileSearch". Here is my codes.
Sub DataIn()
Dim i As Integer
Dim Shell, myPath
Dim filename As String
Dim ws As Worksheet, flag As Boolean
Dim f_Sheet As Long
' ƒ}ƒNƒ’†’fŽž‚Ì•ªŠòæ‚ÌŽw’è
' On Error GoTo Š„žˆ—
' Application.EnableCancelKey = xlErrorHandler
MaxNo = 1
' ƒtƒHƒ‹ƒ_‚Ì‘I‘ð
Set Shell = CreateObject("Shell.Application")
Set myPath = Shell.BrowseForfolder(0&, "ƒf[ƒ^‚ð•Û‘¶‚·‚éƒtƒHƒ‹ƒ_‚ð‘I‚ñ‚Å‚‚¾‚³‚¢", &H41, ThisWorkbook.Path)
If Not myPath Is Nothing Then
If Not myPath.ParentFolder Is Nothing Then
DataFilePath = myPath.Items.Item.Path
Else
Dim objDskTop As Object
Set objDskTop = CreateObject("WScript.Shell")
DataFilePath = objDskTop.SpecialFolders("DeskTop")
Set objDskTop = Nothing
End If
With Application.FileSearch
.LookIn = DataFilePath
.SearchSubFolders = True
.filename = "*.txt"
filename = Dir(DataFilePath & "\" & "*.txt")
If .Execute() > 0 Then
'ƒf[ƒ^—pƒV[ƒg
C_Sheet = Application.ActiveSheet.Name
tmp1 = Mid$(DataFilePath, InStrRev(DataFilePath, "\") + 1)
f_Sheet = 0
For Each ws In Worksheets
If ws.Name = tmp1 Then f_Sheet = 1
Next ws
If f_Sheet = 1 Then
Sheets(tmp1).Select
DataCol = 1
While (Cells(DataCol, 1) <> "")
DataCol = DataCol + 1
Wend
DataCol = DataCol - 1
Else
Sheets.Add After:=Sheets(C_Sheet)
ActiveSheet.Name = tmp1
DataCol = 1
End If
DataSheet = Application.ActiveSheet.Name
'ì‹Æ—pƒV[ƒg
Sheets.Add
TmpSheet = Application.ActiveSheet.Name
For i = 1 To .FoundFiles.Count
Call ReadData(.FoundFiles(i), DataCol)
DataCol = DataCol + 1
Sheets(DataSheet).Select
Next i
' ŒxƒƒbƒZ[ƒW‚Ì”ñ•\ަiƒV[ƒg‚Ìíœj
Application.DisplayAlerts = False
' ’ljÁƒV[ƒg‚Ìíœ
Sheets(TmpSheet).Select
ActiveWindow.SelectedSheets.Delete
' ŒxƒƒbƒZ[ƒW‚Ì•\ަ‰ñ•œ
Application.DisplayAlerts = True
Sheets(DataSheet).Select
Range(Cells(2, 2), Cells(MaxNo + 1, MaxData)).Select
Selection.Sort Key1:=Range(Cells(2, 4), Cells(2, 4)), Order1:=xlAscending, _
Key2:=Range(Cells(2, 3), Cells(2, 3)), Order2:=xlAscending, Header:=xlNo, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, SortMethod:=xlPinYin
Range("A1").Select
Else
MsgBox "ƒf[ƒ^ƒtƒ@ƒCƒ‹‚ª‚ ‚è‚Ü‚¹‚ñB"
End If
End With
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sheets("Main").Select
If Mid(Range("E12").Value, 1, 3) = "SPC" Then
If Mid(Range("E12").Value, 5, 4) = "SKEW" Then
Call copy
Else
Call copy2
End If
Else
Call copy3
End If
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'MsgBox "*** ˆ—‚ªI‚í‚è‚Ü‚µ‚½B ***"
End If
Exit Sub
Š„žˆ—:
' ˆ—’†’f‚Ì“ü—ÍŽž
If Err = 18 Then
If MsgBox("ˆ—‚𒆎~‚µ‚Ü‚·‚©H", vbYesNo) = vbNo Then
Resume
Else
End
End If
Else
MsgBox Error(Err)
End
End If
End Sub
Appreciate the help from everyone.
Thank you very much.
Best regards.
I already resolved the .FileSearch but my problem is the replace of the code below:
For i = 1 To Application.SelectedItems.Count
Call ReadData(.SelectedItems(i), DataCol)
DataCol = DataCol + 1
Sheets(DataSheet).Select
Next i
Thanks.
What are you trying to achieve with that piece of code?
Best regards,
Trowa
Sorry for late reply.
If .txt file/s are found the content of all text files will copied to the sheet in new sheet name