スキルアップ・問題解決なら、モーグにおまかせ！

お世話になっています。
VBA初心者ですが今までにこちらのサイトなどで色々アドバイス受けながら、何とか希望通りの動きをするように作成できました。ですが実行時毎回ではないのですが突然落ちます。コードの内容に負荷をかけてる要素があるかと思い、色々参考にしながら修正してますが自分では原因よくわからずアドバイスお願いしたいです。
 
・転記先…ファイル「一覧表」シート「一覧」「一覧2」…dwb,dws
・転記元…フォルダー「元」内の複数ファイル「元*」…swb,sws
・転記後移動フォルダ「済」
＜シート「一覧」内容＞
�@複数のファイル「元1」「元2]…のシート「1番」D列9行〜に「可」とある行をファイル「一覧」のA列〜E列の９行〜に転記
�Aファイル「元*」のシート「1番」D列9行〜10行の両方に「可」があり、シート「2番」D列9行〜10行に「可」がない場合、「済」フォルダーへ移動
�Bファイル「一覧表」シート「一覧」のB9に文字があればB9セルを基準にソート
�Cファイル「一覧表」シート「一覧」のB列C列が同じであれば同一行を削除
�Dファイル「一覧表」シート「一覧」内に同一行削除でできた罫線なしの空白行を削除
＜シート「一覧2」＞
シート「一覧」と違うのは�Aのみ
�Aファイル「元*」のシート「2番」D列9行〜10行の両方に「可」がある場合、「済」フォルダーへ移動
 
ファイル「一覧表」シート「一覧」「一覧2」…実際は9行〜1000行分A列に番号が入力されており1000行分罫線があります。                
                

   A　　　B　　　C　　　D 　　　　E
1　日付〜				
2				
3　種類〜				
4
5
6　　
7				
8　番号	日付	種類	色	可否
9　1	44928	丸	赤	可
10　2	44958	三角	白	可
11　3	44959	四角	赤	可
12　4				
13　5				
14　6				
15　7				
16　8				
17　9				
18　10				
　〜								
				

 　A      B      C       D
 1元データ			
2
3			
4			
5			
6			
7						
8  日付	    種類 　色	可否
9  2月1日  三角	　白	可
10 2月2日　四角	　赤	可

Sub 一覧表()
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim sFolder As String
    Dim sFile As String
    Dim dFolder As String
    Dim FSO As New Scripting.FileSystemObject
    Dim i As Long
    Dim sLastRow As Long
    Dim dLastRow As Long
    Dim noNeedToMove As Boolean
    Dim RowP As Long

    sFolder = "C:\Users\Documents\一覧\元\"
    sFile = Dir(sFolder & "元*.xlsx")
    dFolder = "C:\Users\Documents\一覧\済\"
    
    If sFile = "" Then
        MsgBox sFolder & "ファイルはありません", vbExclamation, "ファイルなし"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
        
    Set dwb = ThisWorkbook
    Set dws = dwb.Worksheets("一覧")
    
    Do Until sFile = ""
        Set swb = Workbooks.Open(sFolder & sFile)
        Set sws = swb.Worksheets("1番")
        
        noNeedToMove = True
        dLastRow = dws.Cells(dws.Rows.Count, 2).End(xlUp).Row
        With sws
            sLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                For i = 9 To sLastRow
                    If .Cells(i, 4) = "可" Then
                        .Range(.Cells(i, 1), .Cells(i, 4)).Copy
                        dws.Cells(dLastRow + 1, 2).PasteSpecial Paste:=xlPasteValues
                        dLastRow = dLastRow + 1
                    Else
                        noNeedToMove = False
                    End If
                Next i
        End With
        
        If noNeedToMove Then
            With swb.Worksheets("2番")
                If WorksheetFunction.CountIf(.Range(.Cells(9, 4), .Cells(10, 4)), "") <= 2 Then
                    noNeedToMove = False
                End If
            End With
        End If
        swb.Close False
        If noNeedToMove Then
            FSO.MoveFile sFolder & sFile, dFolder
        End If
        sFile = Dir()
     Loop
        If Not dws.Cells(9, 2) = "" Then
            With dws.Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("B9"), Order:=xlAscending
                .SetRange Range(Cells(9, 2), Cells(dLastRow, 5))
                .Header = xlNo
                .Apply
            End With
             
            dws.Range("A9:E" & dLastRow).RemoveDuplicates (Array(2, 3))
        End If
        
       [u] [b]For RowP = dws.[B9].SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
            If Cells(RowP, "A").Borders(xlEdgeRight).LineStyle = xlNone Then
                Rows(RowP).Delete
            End If
        Next RowP[/b][/u]
        
        Set FSO = Nothing
        Set swb = Nothing
        Set sws = Nothing
        Set dwb = Nothing
        Set dws = Nothing
        
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
    
End Sub

Sub 一覧2()
    Dim swb As Workbook
    Dim sws As Worksheet
    Dim dwb As Workbook
    Dim dws As Worksheet
    Dim sFolder As String
    Dim sFile As String
    Dim dFolder As String
    Dim FSO As New Scripting.FileSystemObject
    Dim i As Long
    Dim sLastRow As Long
    Dim dLastRow As Long
    Dim noNeedToMove As Boolean
    Dim RowP As Long
    'コピー元ファイル
    sFolder = "C:\Users\Documents\一覧\元\"
   
    sFile = Dir(sFolder & "元*.xlsx")
    'コピー後の移動フォルダー
     dFolder = "C:\Users\Documents\一覧\済\"
    
    If sFile = "" Then
        MsgBox sFolder & "ファイルはありません", vbExclamation, "ファイルなし"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
        
    Set dwb = ThisWorkbook
    Set dws = dwb.Worksheets("一覧2")
    
    Do Until sFile = ""
        Set swb = Workbooks.Open(sFolder & sFile)
        Set sws = swb.Worksheets("2番")
        
        noNeedToMove = True
        dLastRow = dws.Cells(dws.Rows.Count, 2).End(xlUp).Row
        With sws
            sLastRow = .Cells(.Rows.Count, 1).End(xlUp).Row
                For i = 9 To sLastRow
                    If .Cells(i, 4) = "可" Then
                        .Range(.Cells(i, 1), .Cells(i, 4)).Copy
                        dws.Cells(dLastRow + 1, 2).PasteSpecial Paste:=xlPasteValues
                        dLastRow = dLastRow + 1
                    Else
                        noNeedToMove = False
                    End If
                Next i
        End With
        
        swb.Close False
        If noNeedToMove Then
            FSO.MoveFile sFolder & sFile, dFolder
        End If
        sFile = Dir()
     Loop
        If Not dws.Cells(9, 2) = "" Then
            With dws.Sort
                .SortFields.Clear
                .SortFields.Add Key:=Range("B9"), Order:=xlAscending
                .SetRange Range(Cells(9, 2), Cells(dLastRow, 5))
                .Header = xlNo
                .Apply
            End With
             
            dws.Range("A9:E" & dLastRow).RemoveDuplicates (Array(2, 3))
        End If
        
       [u] [b]For RowP = dws.[B9].SpecialCells(xlCellTypeLastCell).Row To 1 Step -1
            If Cells(RowP, "A").Borders(xlEdgeRight).LineStyle = xlNone Then
                Rows(RowP).Delete
            End If
        Next RowP[/b][/u]
        
        Set FSO = Nothing
        Set swb = Nothing
        Set sws = Nothing
        Set dwb = Nothing
        Set dws = Nothing
        
        Application.ScreenUpdating = True
        Application.EnableEvents = True
        Application.Calculation = xlCalculationAutomatic
    
End Sub

Excelが落ちる原因はわかりません。データが悪さをしているケースもあるでしょうから。
関係ないことも含めて気づいたことをメモします。
質問1
    罫線の状況を見て、行削除してるようですが、転記は値だけですよね。
    すると、もともと罫線がないところに、値転記すると、それは行削除の対象になるんですか？
質問2
    If WorksheetFunction.CountIf(.Range(.Cells(9, 4), .Cells(10, 4)), "") <= 2 Then
    これが、False判定されるケースってどんなケースですか？
    2個のセルを調べて、2個以下かどうかなら、すべてTrueでは？
質問3
    セル参照にシート指定が漏れているところがあります。
    人任せにせず、コードをきちんと見たほうがいいですよ。

simple さんの引用:
Excelが落ちる原因はわかりません。データが悪さをしているケースもあるでしょうから。
関係ないことも含めて気づいたことをメモします。
質問1
    罫線の状況を見て、行削除してるようですが、転記は値だけですよね。
    すると、もともと罫線がないところに、値転記すると、それは行削除の対象になるんですか？
質問2
    If WorksheetFunction.CountIf(.Range(.Cells(9, 4), .Cells(10, 4)), "") <= 2 Then
    これが、False判定されるケースってどんなケースですか？
    2個のセルを調べて、2個以下かどうかなら、すべてTrueでは？
質問3
    セル参照にシート指定が漏れているところがあります。
    人任せにせず、コードをきちんと見たほうがいいですよ。

行削除は、コストの高い処理です。（Excelにとって負荷が高く、時間もかかります。）
罫線は最初はなしにしておいて、データのあるところだけに罫線を付けるほうがよくないですか？
構造的な問題は、
�@シート指定の話と、
�A上記の行削除を避けるべき、という点くらいですかね。
 
 
あと、細かい話で、こちらがどうこうコメントする話でもないのですが、
感想としてコメントしておきます。
(1)

WorksheetFunction.CountIf(.Range(.Cells(9, 4), .Cells(10, 4)), "") 

[quote="simple"]行削除は、コストの高い処理です。（Excelにとって負荷が高く、時間もかかります。）
罫線は最初はなしにしておいて、データのあるところだけに罫線を付けるほうがよくないですか？
構造的な問題は、
�@シート指定の話と、
�A上記の行削除を避けるべき、という点くらいですかね。
 
行削除は負荷をかける処理なのですね。そういったことを知らなかったので助かります。
的確なアドバイスありがとうございます。
表の方は罫線なしにして転記された行だけ罫線を引くという方法に変更してみます。
 
他色々ご指摘ありがとうございます。
確かにわかりにくい、おかしな点が色々ありましたので修正していこうと思います。
ありがとうございました。