Solved: Count Files in folder & cell.value=NewFile.Name

[omnibuster]

Hi.
Need Help.
How disable variant: if controlled WorkBook (get name cell.Value) excist then
do nothing and if not exist make new.(Rename by Cell.Value).
What I do wrong
Option Explicit
Public Sub MakeNew() 'Like "AA*"<>
Dim LastRow As Long, mycheck As Boolean, mycheck2 As Boolean, i As Integer, X As String
Dim objFso As FileSystemObject, objFolder As folder, objFile As file, strSourceFolder As String, strDestFolder As String
Dim Counter As Integer, strNewFileName As String, strName As String, strExt As String
Sheets("Sheet1").Select
LastRow = Range("A1").End(xlDown).Row
For i = 1 To LastRow
Range("D" & i).Activate
mycheck = Range("D" & i).Value Like "*T"
mycheck2 = Range("D" & i).Value Like "*T "
If mycheck = True Or mycheck2 = True Then
Range("D" & i).Activate

strSourceFolder = ThisWorkbook.Path
strDestFolder = ThisWorkbook.Path
Set objFso = New FileSystemObject
Set objFolder = objFso.GetFolder(strSourceFolder)
Counter = 0
For Each objFile In objFolder.Files

If objFile.Name = ("Main.xls") Then GoTo 10
If objFile.Name = ("AABAA.xls") Then GoTo 10

If objFile.Name = Range("D" & i).Value & ".xls" Then GoTo 10
If objFile.Name <> Range("D" & i).Value & ".xls" Then

' Copy File "AABAAA", File Rename Range("D" & i).Value & ".xls" ????

strName = ("AABAA.xls") 'Left(objFile.Name, Len(objFile.Name) - 4)
strExt = Range("D" & i).Value & ".xls" 'GetNewFileName
strNewFileName = strExt
objFile.Copy strDestFolder & "\" & strNewFileName
End If
Counter = Counter + 1
10

Next objFile
Set objFile = Nothing: Set objFso = Nothing: Set objFolder = Nothing
End If
Next i
End Sub

[mdmackillop]

I don't quite follow what you are trying to achieve here. Can you clarify the copying/renaming in the loop? To rename an existing file, then use the Name function as in
If objFile.Name <> Range("D" & i).Value & ".xls" Then

Name strSourceFolder & "\" & objFile.Name As strSourceFolder & "\" & Range("D" & i).Value & ".xls"

[omnibuster]

I don't quite follow what you are trying to achieve here. Can you clarify the copying/renaming in the loop? To rename an existing file, then use the Name function as in
If objFile.Name <> Range("D" & i).Value & ".xls" Then

Name strSourceFolder & "\" & objFile.Name As strSourceFolder & "\" & Range("D" & i).Value & ".xls"

Thanks mdmackillop.
I make some changes and code works, but I dont undestand why code overwriting exsitings file??
I was thinking this red-color part should disable overwriting excisting file??


Public Sub MakeNew() 'Like "AA*"<>
Dim LastRow As Long, mycheck As Boolean, mycheck2 As Boolean, i As Integer, X As String
Dim objFso As FileSystemObject, objFolder As folder, objFile As file, strSourceFolder As String, strDestFolder As String
Dim Counter As Integer, strNewFileName As String, strName As String, strExt As String
Sheets("Sheet1").Select
LastRow = Range("D1").End(xlDown).Row
For i = 1 To LastRow
Range("D" & i).Activate
mycheck = Range("D" & i).Value Like "*1T"
mycheck2 = Range("D" & i).Value Like "*1T "
If mycheck = True Or mycheck2 = True Then
Range("D" & i).Activate

strSourceFolder = ThisWorkbook.Path
strDestFolder = ThisWorkbook.Path
Set objFso = New FileSystemObject
Set objFolder = objFso.GetFolder(strSourceFolder)

For Each objFile In objFolder.Files
Counter = 0
If objFile.Name <> ("Main.xls") Or objFile.Name <> ("Template.xls") Or objFile.Name <> Range("D" & i).Value & ".xls" Then

strNewFileName = Range("D" & i).Value & ".xls" 'strExt
objFile.Copy strDestFolder & "\" & strNewFileName
End If
Counter = Counter + 1
Next objFile

End If
Next i
Set objFile = Nothing: Set objFso = Nothing: Set objFolder = Nothing
End Sub

[mdmackillop]

How about Select Case, I prefer it to multiple Or
Select Case objFile.Name
Case "Main.xls", "Template.xls", Range("D" & i).Value & ".xls"
'do nothing
Case Else
strNewFileName = Range("D" & i).Value & ".xls" 'strExt
objFile.Copy strDestFolder & "\" & strNewFileName
End Select
Maybe use Option Compare Text as well to avoid possible Upper/Lower case errors

[omnibuster]

Thanks for replay. mdmackillop.
In VBA Im beginner-newby.
Dont know still how use "Cases".

[mdmackillop]

Option Explicit '<=== Requires variables to be declared
Option Compare Text '<=== Ignores upper/lower case in text comparison

Public Sub MakeNew()
Dim LastRow As Long, mycheck As Boolean, mycheck2 As Boolean, i As Integer, X As String
Dim objFso As FileSystemObject, objFolder As folder, objFile As file, strSourceFolder As String, strDestFolder As String
Dim Counter As Integer, strNewFileName As String, strName As String, strExt As String
Sheets("Sheet1").Select
LastRow = Range("D1").End(xlDown).Row
For i = 1 To LastRow
Range("D" & i).Activate
mycheck = Range("D" & i).Value Like "*1T"
mycheck2 = Range("D" & i).Value Like "*1T "
If mycheck = True Or mycheck2 = True Then
Range("D" & i).Activate

strSourceFolder = ThisWorkbook.Path
strDestFolder = ThisWorkbook.Path
Set objFso = New FileSystemObject
Set objFolder = objFso.GetFolder(strSourceFolder)

For Each objFile In objFolder.Files
Counter = 0
Select Case objFile.Name
Case "Main.xls", "Template.xls", Range("D" & i).Value & ".xls"
'do nothing
Case Else
strNewFileName = Range("D" & i).Value & ".xls"
objFile.Copy strDestFolder & "\" & strNewFileName
End Select

Counter = Counter + 1
Next objFile

End If
Next i
Set objFile = Nothing: Set objFso = Nothing: Set objFolder = Nothing
End Sub

[omnibuster]

Thanks for help mdmackillop.
Make some changes and code works good for me.

Option Explicit '<=== Requires variables to be declared
Option Compare Text '<=== Ignores upper/lower case in text comparison
Sub RunCodeOnAllXLSFiles()
Dim LastRow As Long, mycheck As Boolean, mycheck2 As Boolean, i As Integer
Dim objFso As FileSystemObject, objFolder As folder, objFile As file, strSourceFolder As String, strDestFolder As String
Dim Counter As Integer, strNewFileName As String, strName As String, strExt As String, strobjFile As String
Dim lCount As Long, wbResults As Workbook, wbCodeBook As Workbook, y As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.EnableEvents = False
On Error Resume Next
Sheets("Sheet1").Select
LastRow = Range("D1").End(xlDown).Row
For i = 1 To LastRow
Range("D" & i).Activate
mycheck = Range("D" & i).Value Like "*T" Or Range("D" & i).Value Like "*T "
If mycheck = True Then
Range("D" & i).Activate
y = ActiveCell.Value & ".xls"
If y = False And Not TypeName(y) = "String" Then Exit Sub
Set wbCodeBook = ThisWorkbook
With Application.FileSearch
.NewSearch
.LookIn = ThisWorkbook.Path '"C:\MyDocuments\TestResults"
.Filename = y
If .Execute > 0 Then
'For lCount = 1 To .FoundFiles.count 'Loop through all.
'Set wbResults = Workbooks.Open(Filename:=.FoundFiles(lCount), UpdateLinks:=0)
'DO YOUR CODE HERE
' wbResults.Close SaveChanges:=True
' Next lCount
Else
strSourceFolder = ThisWorkbook.Path
strDestFolder = ThisWorkbook.Path
Set objFso = New FileSystemObject
Set objFolder = objFso.GetFolder(strSourceFolder)
For Each objFile In objFolder.Files
Counter = 0
If objFile.Name = ("AABAA.xls") Then
strNewFileName = Range("D" & i).Value & ".xls"
objFile.Copy strDestFolder & "\" & strNewFileName
GoTo 10
Else
GoTo 10 'Get next Name for Find
End If
Counter = Counter + 1
Next objFile
End If
End With
End If
10
Next
Set objFile = Nothing: Set objFso = Nothing: Set objFolder = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.EnableEvents = True
End Sub

[mdmackillop]

Try to avoid Activating/Selecting Cells
'For
Range("D" & i).Activate
mycheck = Range("D" & i).Value Like "*T" Or Range("D" & i).Value Like "*T "
'Use
mycheck = Range("D" & i).Value Like "*T" Or Range("D" & i).Value Like "*T "

'for
Range("D" & i).Activate
y = ActiveCell.Value & ".xls"

'use
y = Range("D" & i) & ".xls"


Here, Counter is not used
For Each objFile In objFolder.Files
Counter = 0
If objFile.Name = ("AABAA.xls") Then
strNewFileName = Range("D" & i).Value & ".xls"
objFile.Copy strDestFolder & "\" & strNewFileName
Goto 10
Else
Goto 10 'Get next Name for Find
End If
Counter = Counter + 1
Next objFile

Redundant GoTo 10
If objFile.Name = ("AABAA.xls") Then
strNewFileName = Range("D" & i).Value & ".xls"
objFile.Copy strDestFolder & "\" & strNewFileName
End If
GoTo 10


It takes a bit of work to streamline code, but it is neater, more efficient and less prone to errors if you can do so.

[omnibuster]

Thanks mdmackillop