Collect Info from Wkbks in a Folder with Criteria to 1 sheet. CHAL

[Joel]

You need to add a variable FOUND like I did in the code below.

1ST ATTEMPT
Sub Transfer()

' Transfer Macro

' Keyboard Shortcut: Option+Cmd+x

Application.ScreenUpdating = False

Mymonth = Range("A1")
Do While Mymonth = ""
Answer = MsgBox("Enter Name of Month (ALL CAPS)", vbOKOnly)
If Answer = vbOK Then Exit Sub
Loop

Set NewSht = ThisWorkbook.ActiveSheet
'Clear the Content Below, so if user Cancel, the old info is still exist.
'NewSht.Range("A2:E100").ClearContents
'NewSht.Range("G2:G100").ClearContents

Folder = "Users:Neonesktop:TEST FOLDER:"
FName = Dir(Folder, MacID("XLS8"))


Answer = MsgBox("Found files: " & FName & ". Would you like to proceed?",
vbOKCancel)
If Answer = vbCancel Then Exit Sub

NewSht.Range("A2:E100").ClearContents
NewSht.Range("G2:G100").ClearContents

Newrowcount = 2
Found = False
Do While FName <> ""
Set OldBk = Workbooks.Open(Filename:=Folder & FName)
For Each Sht In OldBk.Sheets
'MsgBox ("check Sheet : " & Sht.Name)
With Sht
Oldrowcount = 7
' Attempt to change from Range B to A for searching by "greater
than A"
Do While .Range("B" & Oldrowcount) <> ""

'If Not Match, Show the Message Box.
If UCase(.Range("B" & Oldrowcount)) = Mymonth Then
Found = True

.Range("A" & Oldrowcount).Copy
NewSht.Range("A" & Newrowcount).PasteSpecial
Paste:=xlPasteValues
.Range("C" & Oldrowcount).Copy
NewSht.Range("D" & Newrowcount).PasteSpecial
Paste:=xlPasteValues
.Range("D" & Oldrowcount).Copy
NewSht.Range("E" & Newrowcount).PasteSpecial
Paste:=xlPasteValues
.Range("B" & Oldrowcount).Copy
NewSht.Range("G" & Newrowcount).PasteSpecial
Paste:=xlPasteValues
.Range("B1").Copy
NewSht.Range("B" & Newrowcount).PasteSpecial
Paste:=xlPasteValues

Newrowcount = Newrowcount + 1
End If
Oldrowcount = Oldrowcount + 1
Loop
End With
Next Sht
OldBk.Close savechanges:=False
FName = Dir()
Loop
if Found = False then
Answer = MsgBox("There is no information match your specified query.",
vbOKOnly)
If Answer = vbOK Then Exit Sub
end if

Application.ScreenUpdating = True

End Sub