以下のvbaが処理が完了しない方がいます。自己流のＶＢＡのコーディングにアドバイスお願いします。

共通しているのは３０分放置しても処理が完了せず、青いわっかがぐるぐる回っているとのこと。

Sub Macro1抽出()

Dim st1 As Worksheet
Dim st2 As Worksheet
Dim st3 As Worksheet

'処理中の動きを固定
Application.ScreenUpdating = False
'アラートも表示禁止
Application.DisplayAlerts = False
'パスは現在のエクセルがあるところに設定
wpath = ThisWorkbook.Path

Set st1 = ThisWorkbook.Worksheets("Extract_EmailAddress")
Set st2 = ThisWorkbook.Worksheets("貼付")
Set st3 = ThisWorkbook.Worksheets("個別削除対象メール")

'抽出結果シートのクリア
st1.Cells.ClearContents

'範囲指定
Dim cellrow As Long
Dim cellhight As Long

'複数行単一化-------------------------------
'A列B列C列で落ちてきているアドレスデータをA列一列だけにまとめる

'最右列を取得
cellrow = st2.Cells(1, Columns.Count).End(xlToLeft).Column

    For x = 1 To cellrow - 1
        cellheight = st2.Cells(Rows.Count, x).End(xlUp).Row
        If st2.Cells(Rows.Count, x + 1).End(xlUp).Row > 1 Then
        Range(st2.Cells(2, x + 1), st2.Cells(st2.Cells(Rows.Count, x + 1).End(xlUp).Row + 1, x + 1)).Copy
        st2.Cells(st2.Cells(Rows.Count, 1).End(xlUp).Row, 1).PasteSpecial Paste:=xlPasteValues
    End If
Next x
'--------------------------------------------

'移し終わったので移した列を消す
    st2.Columns("B:E").ClearContents

'-------------------------------------------------移し替えたA列並び替え
    ' ソート対象の列を指定
    Dim sortColumn As Range
    Set sortColumn = st2.Range("A2:A" & st2.Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 昇順でソート
    sortColumn.Sort key1:=sortColumn, order1:=xlAscending, Header:=xlNo
'--------------------------------------------------



'--------------------------------------------------重複削除

    Dim dataRange As Range
    Set dataRange = st1.Range("A2:A" & st1.Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 重複データの削除
    dataRange.RemoveDuplicates Columns:=Array(1), Header:=xlNo
'--------------------------------------------------


    ' データの並べ替えを行うVBAスクリプト
'-------------------------------------------------並び替え
    ' ソート対象の列を指定

    Set sortColumn = st1.Range("A2:A" & st1.Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 昇順でソート
    sortColumn.Sort key1:=sortColumn, order1:=xlAscending, Header:=xlNo
'--------------------------------------------------

'@のつくものについてはすべて抽出結果シートに移動させる
'------------------------------------------------（メールアドレス抽出）
    hh = "'" & st2.Name & "'!" & st2.Range(st2.Cells(2, 1), st2.Cells(st2.Cells(Rows.Count, 1).End(xlUp).Row, 1)).Address  'チェック表の1列目
    ThisWorkbook.Activate
    Set nnt = Range(hh).Find("@", LookAt:=xlPart)  '
        If nnt Is Nothing Then
　　　　　　'ActiveDirectory用のメールは@を含むものもあり、文字数がめちゃめちゃ長いのでいったん７０文字以下の制限をつけて処理
      
        ElseIf Len(nnt.Value) < 70 Then
         st1.Cells(st1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = st2.Cells(nnt.Row, 1).Value
        Else
        End If
        
　　　'FindNextで発見行以降も検索
    Dim myCell As Range
    Set myCell = nnt
    Do
         Set myCell = Range(hh).FindNext(myCell)
         If myCell Is Nothing Then
         Else
         st1.Cells(st1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = st2.Cells(myCell.Row, 1).Value
         End If
    Loop While myCell.Row <> nnt.Row
'Extract_EmailAddress-----------------------------

'セミコロンで位置区切り-----------------------
st1.Select
    st1.Range(st1.Cells(2, 1), st1.Cells(st1.Cells(Rows.Count, 1).End(xlUp).Row, 1)).Select
    Selection.TextToColumns Destination:=Range("A2"), DataType:=xlDelimited, _
        TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
        Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
        :=Array(1, 1), TrailingMinusNumbers:=True
'-------------------------------------------

'区切ったアドレスをすべてＡ列の下に並べていく
  For xx = 2 To st1.Range("A1").SpecialCells(xlCellTypeLastCell).Column

    For yy = 2 To st1.Range("A1").SpecialCells(xlCellTypeLastCell).Row
  
      st1.Cells(st1.Cells(Rows.Count, 1).End(xlUp).Row + 1, 1) = st1.Cells(yy, xx).Value
  
  
    Next yy
  Next xx
'-------------------------------------------
'すべてＡ列に並べ終えたので処理がおわったＡ列以外を消す
    st1.Columns("B:" & st1.Range("A1").SpecialCells(xlCellTypeLastCell).Column).ClearContents

'自社内のアドレス使うもの（自社在籍者）を消す
 For k = 2 To st1.Cells(Rows.Count, 1).End(xlUp).Row
    If InStr(st1.Cells(k, 1).Value, "@dowatec.co.jp") > 0 Then
      st1.Cells(k, 1).ClearContents
    End If
 Next k
 
'/oから始まるActiveDirectoryアドレスも消す
 For k = 2 To st1.Cells(Rows.Count, 1).End(xlUp).Row
    If Mid(st1.Cells(k, 1), 1, 1) = "/" Then
      st1.Cells(k, 1).ClearContents
    End If
 Next k
'空欄ができたので並び替え
'-------------------------------------------------並び替え
    ' ソート対象の列を指定

    Set sortColumn = st1.Range("A2:A" & st1.Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 昇順でソート
    sortColumn.Sort key1:=sortColumn, order1:=xlAscending, Header:=xlNo
'--------------------------------------------------


'-------------------------------------------------シングルクォーテーション削除

    For e = 2 To st1.Cells(Rows.Count, 1).End(xlUp).Row
      If Mid(st1.Cells(e, 1), 1, 1) = "'" Then
      ' シングルクォーテーションがある場合のみ値をコピー（PrefixCharacterプロパティで「'」が返される）
        st1.Cells(e, 1) = Mid(st1.Cells(e, 1).Value, 2, 100)
      End If

      If Mid(st1.Cells(e, 1), Len(st1.Cells(e, 1)), Len(st1.Cells(e, 1))) = "'" Then
      ' シングルクォーテーションがある場合のみ値をコピー（PrefixCharacterプロパティで「'」が返される）
        st1.Cells(e, 1) = Mid(st1.Cells(e, 1).Value, Len(st1.Cells(e, 1)), Len(st1.Cells(e, 1)))
      End If
    Next

'-------------------------------------------------並び替え

    ' ソート対象の列を指定

    Set sortColumn = st1.Range("A2:A" & st1.Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 昇順でソート
    sortColumn.Sort key1:=sortColumn, order1:=xlAscending, Header:=xlNo
'--------------------------------------------------
'--------------------------------------------------重複削除（シングルクォーテーションのついたメールで重複のあるものがでてくるので）

    Set dataRange = st1.Range("A2:A" & st1.Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 重複データの削除
    dataRange.RemoveDuplicates Columns:=Array(1), Header:=xlNo
'--------------------------------------------------

'------------------------------------------------（メールアドレス抽出tec）新しいメールアドレスを使っている自社在籍者をリストを使ってアカウント削除

    hh = "'" & st1.Name & "'!" & st1.Range(st1.Cells(2, 1), st1.Cells(st1.Cells(Rows.Count, 1).End(xlUp).Row, 1)).Address  'チェック表の1列目
    ThisWorkbook.Activate
    For i = 2 To st3.Cells(Rows.Count, 5).End(xlUp).Row
    Set nnt = Range(hh).Find(st3.Cells(i, 5).Value, LookAt:=xlPart) '
        If nnt Is Nothing Then

        Else
         st1.Cells(nnt.Row, 1).ClearContents
        End If
    Next i
'--------------------------------------------------
'-------------------------------------------------並び替え（空欄ができるので）
    ' ソート対象の列を指定

    Set sortColumn = st1.Range("A2:A" & st1.Cells(Rows.Count, 1).End(xlUp).Row)
    
    ' 昇順でソート
    sortColumn.Sort key1:=sortColumn, order1:=xlAscending, Header:=xlNo
'--------------------------------------------------
  


Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.DisplayAlerts = True

End Sub

/o=ExchangeLabs/ou=Exchange Administrative Group (FYDIBOHF23SPDLT)/cn=Recipients/cn=160f852ec34d48bd8c967f7633abb20f-d5bff60a-74

def greet
  puts Hello World
end