BD9ｾﾙにP180303550.jpgというようなP＋数字＋.jpgの組み合わせで桁数は常にかわらないものがはいっているｴｸｾﾙﾌｧｲﾙのｼｰﾄがｱｸﾃｨﾍﾞｲﾄになっているとすると，こんな感じでいけるのではないかと思います｡(debugしてないので自信ないけど，FileSystemObjectを使うので自己責任でお願いします｡)
Sub ﾌｧｲﾙ名を区別して特定ﾌｫﾙﾀﾞに移動したい()
Set FS = CreateObject("Scripting.FileSystemObject")
BASE_FILE_NAME = ThisWorkbook.ActiveSheet.Range("BD9")
Select Case IsEmpty(BASE_FILE_NAME)
Case True
Case False
BASE_NUMBER = Val(Mid(BASE_FILE_NAME, 2, 6))
DIR_FROM = "C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\jiriki\" & Format(BASE_NUMBER) & "\"
Select Case FS.FolderExists(DIR_FROM)
Case True
DIR_AUC1 = "C:\Users\naranara19\Desktop\auc\"
Select Case FS.FolderExists(DIR_AUC1)
Case True
Case False
MkDir DIR_AUC1
End Select
DIR_AUC2 = "C:\Users\naranara19\Desktop\auc2\"
Select Case FS.FolderExists(DIR_AUC2)
Case True
MkDir DIR_AUC2
Case False
End Select
For Each F In FS.GetFolder(DIR_FROM).Files
Select Case Mid(F.Name, Len(F.Name) - 3, 4)
Case ".jpg"
Select Case Mid(F.Name, 1, 1)
Case "P"
Select Case Val(Mid(F.Name, 2, 6))
Case Is > BASE_NUMBER
DIR_AUC = DIR_AUC1
Case Else
DIR_AUC = DIR_AUC2
End Select
F.Move DIR_AUC
Case Else
End Select
Case Else
End Select
Next
Case False
End Select
End Select
End Sub

2018/03/05 07:54ｺｰﾄﾞ差し替えを行いました｡

こんな感じでできませんでしょうか？
ﾌｫﾙﾀﾞｰの有無や境界値となるBD9のｾﾙの値などﾃﾞｰﾀの整合性のﾁｪｯｸ処理､およびｴﾗｰ発生時の処理は入れてありません｡必要に応じて追加していただければと思います｡

Public Sub movePictures改()

 '元ﾃﾞｰﾀﾌｫﾙﾀﾞ
 Const SOURCE_FOLDER_MAIN As String = "C:\Users\naranara19\Desktop\PC移動受け\写真(現在)\"
 Const SOURCE_FOLDER_SUB As String = "\jiriki"

 '移動対象拡張子
 Const TARGET_EXTENTION As String = ".jpg"

 '移動先ﾌｫﾙﾀﾞ
 Const DEST_FOLDER1 As String = "C:\Users\naranara19\Desktop\auc"
 Const DEST_FOLDER2 As String = "C:\Users\naranara19\Desktop\auc2"

 'ﾌｧｲﾙ名桁数
 Const FILE_NAME_LENGTH As Long = 10

 '親ﾌｫﾙﾀﾞ名桁数
 Const PARENT_FOLDER_NAME_LENGTH As Long = 6
 '親ﾌｫﾙﾀﾞ名開始位置
 Const PARENT_FOLDER_NAME_BEGIN_POS As Long = 2

 '境界となるﾌｧｲﾙ名の記載されているｼｰﾄ
 Const TARGET_SHEET_NAME As String = "Sheet1"

 '境界となるﾌｧｲﾙ名の記載されているｾﾙ
 Const TARGET_CELL_ADDRESS As String = "BD9"

 Dim fso As New FileSystemObject
 Dim f As FILE
 Dim sFileName As String
 Dim sBoundary As String
 Dim sParentFolderName As String
 Dim sSourceFolder As String
 Dim sSourcePath As String
 Dim sDestPath As String

 '境界となるﾌｧｲﾙ名の取得
 sBoundary = ThisWorkbook.Worksheets(TARGET_SHEET_NAME).Range(TARGET_CELL_ADDRESS).Value
 sBoundary = Left$(sBoundary, FILE_NAME_LENGTH)

 '親ﾌｫﾙﾀﾞ名(可変部)の取得
 sParentFolderName = Mid$(sBoundary, PARENT_FOLDER_NAME_BEGIN_POS, PARENT_FOLDER_NAME_LENGTH)

 '親ﾌｫﾙﾀﾞの設定
 sSourceFolder = SOURCE_FOLDER_MAIN & sParentFolderName & SOURCE_FOLDER_SUB

 For Each f In fso.GetFolder(sSourceFolder).Files
 '対象拡張子かの判定
 If LCase(Right$(f.Name, Len(TARGET_EXTENTION))) = TARGET_EXTENTION Then
 sFileName = Left$(f.Name, FILE_NAME_LENGTH)

 If sFileName >= sBoundary Then
 '境界値以上
 sDestPath = DEST_FOLDER2
 Else
 '境界値未満
 sDestPath = DEST_FOLDER1
 End If

 sSourcePath = sSourceFolder & "\" & f.Name
 sDestPath = sDestPath & "\" & f.Name

 '移動
 Call fso.MoveFile(sSourcePath, sDestPath)
 End If
 Next

 Set fso = Nothing

End Sub