もとのｿｰｽをｺﾒﾝﾄに貼り付けてもらえれば 修正は 早いんですけどね｡

一応､直し方だけ｡

for a=4 to 65536
この行の前に ﾌﾗｸﾞをｸﾘｱします｡
ﾌﾗｸﾞは 変数 flg とでもしましょう｡

flg = 0
for a=4 to 65536

こんな感じです｡

で exit for の前に ﾌﾗｸﾞをたてます｡
つまり､見つかったら ﾌﾗｸﾞを 1にするのです｡

flg = 1
exit for

で Next a の次に

if flg = 0 then
と入れて
for a=4 to 65536
から
Next a
の部分までを ｺﾋﾟｰして 入れます｡
そして 大型のところを 中型にします｡

Next aの次に
end if
と入れます｡

この中型の箇所

if flg = 0 then
から
end if
までをｺﾋﾟｰし､今度は 中型を 小型に変えます｡

これで OKです｡

前段の部分が良く見えませんが､Dir 以降をこんな形にしてどうでしょうか｡

Sub japan_nan()

     ：
     ：
     ：

 Dim wb As Workbook
 Dim fileName
 fileName = Dir(p & "\" & "*.xls", vbNormal)
 Do While fileName <> ""
 Set wb = Workbooks.Open(p & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
 mySearch wb, Split(fileName, "･")(1) '// ***･県名･*** から県名を取得
 wb.Close
 fileName = Dir
 Loop
End Sub

Sub mySearch(srcWB As Workbook, prefName)
 Dim productName As String
 Dim wsName
 Dim dstWS As Worksheet
 Dim dstRow As Range
 Dim r As Long
 For Each wsName In Array("大型", "中型", "小型")
 With srcWB.Worksheets(wsName)
 For r = 4 To Rows.Count
 productName = StrConv(.Cells(r, "D"), vbWide)
 If productName = "" Then Exit For
 
 On Error Resume Next
 Set dstWS = ThisWorkbook.Worksheets(productName)
 On Error GoTo 0
 
 If Not dstWS Is Nothing Then
 dstRow = dstWS.Cells(Rows.Count, "B").End(xlUp).Row + 1
 dstWS.Cells(dstRow, "B").Value = prefName
 dstWS.Cells(dstRow, "C").Value = productName
 dstWS.Cells(dstRow, "G").Value = .Range("J2")
 dstWS.Cells(dstRow, "H").Value = .Cells(r, "H")
 Exit Sub
 End If
 Next
 End With
 Next
End Sub

ただ､あるﾌｫﾙﾀﾞの中にあるEXCEL ﾌｧｲﾙの中から 大型､中型､小型のｼｰﾄを
順番に見ていき､最初に ThisWorkbook の中のｼｰﾄ名と同じ製品名があったら､それを追記する(2つ目以降を見ない)というのが仕様かどうかが気になりました｡

??????????????????????????????????
下記追記

また､全角変換したﾃﾞｰﾀをｼｰﾄ名と比較していますが､ｼｰﾄ名はすべて全角で書かれているのでしょうか｡
下記で確認してはどうかと思います｡

Sub wideCheck()
 Dim ws As Worksheet
 For Each ws In Worksheets
 If ws.Name <> StrConv(ws.Name, vbWide) Then
 MsgBox "ｼｰﾄ名に半角文字が含まれています｡"
 End If
 Next
End Sub

ｱｸﾃｨﾌﾞﾌﾞｯｸの全部のｼｰﾄ名を全角変換するには下記でできます｡
うえで引っかかるようでしたら､これを実施した後に最初のｺｰﾄﾞを実行してみてどうでしょうか｡

Sub wideConv()
 Dim ws As Worksheet
 For Each ws In Worksheets
 ws.Name = StrConv(ws.Name, vbWide)
 Next
End Sub

ｺﾒﾝﾄに提示されたｺｰﾄﾞは見づらいので下記に掲載しました(一部修正)｡

Option Explicit

Private Sub CommandButton1_Click()
 Dim ShellApp As Object
 Dim oFolder As Object
 Dim wb As Workbook
 Dim fileName
 Set ShellApp = CreateObject("Shell.Application")
 Set oFolder = ShellApp.BrowseForFolder(0, "ﾌｫﾙﾀﾞ選択", 1)
 MsgBox oFolder.Items.Item.Path, vbOKOnly, "ﾌﾙﾊﾟｽ表示！"
 
 Dim p
 p = oFolder.Items.Item.Path
 
 fileName = Dir(p & "\" & "*.xls", vbNormal)
 Do While fileName <> ""
 Set wb = Workbooks.Open(p & "\" & fileName, UpdateLinks:=False, ReadOnly:=True)
 mySearch wb, Split(fileName, "･")(1) '// ***･県名･*** から県名を取得
 wb.Close
 fileName = Dir
 Loop

'// ★移動：ThisWorkbook へ対する処理ならこちらで実施すべき
 Application.ScreenUpdating = False
 Dim Sht As Worksheet
 For Each Sht In Worksheets
 Sht.Select
  'Call Nyuryoku
 Call AverageSheet
  'Call ClearCon
 Call SumSheet
  'Call ClearCon
 Next Sht
 Application.ScreenUpdating = True
End Sub
 
Sub mySearch(srcWB As Workbook, prefName)
 Dim productName As String
 Dim wsName
 Dim dstWS As Worksheet
 Dim dstRow As Long
 Dim r As Long
 For Each wsName In Array("大型", "ﾊﾟﾁﾝｺ", "ｽﾛｯﾄ")
 With srcWB.Worksheets(wsName)
 For r = 4 To Rows.Count
 productName = StrConv(.Cells(r, "D"), vbWide)
 If productName = "" Then Exit For
 On Error Resume Next
 Set dstWS = ThisWorkbook.Worksheets(productName)
 On Error GoTo 0
 
 If Not dstWS Is Nothing Then
 dstRow = dstWS.Cells(Rows.Count, "B").End(xlUp).Row + 1
 dstWS.Cells(dstRow, "B").Value = prefName
 dstWS.Cells(dstRow, "C").Value = productName
 dstWS.Cells(dstRow, "G").Value = .Range("J2")
 dstWS.Cells(dstRow, "H").Value = .Cells(r, "H")
 Set dstWS = Nothing '// 一応おまじない
  ' すべてを検索する場合は?､?とも削除
 Exit Sub  ' // ?見つけたら次のﾌｧｲﾙを検索
  ' Exit For ' // ?見つけたら次のｼｰﾄを検索
 End If
 Next
 End With
 Next
End Sub

各ﾌｧｲﾙはｼｰﾄ名に半角文字が使われているようですが､全角･半角の運用は意図通りになっているでしょうか｡