篩選快接近1萬筆的資料速度超慢

這個需求是這樣

這是篩選條件有一個篩選的區間對應站別
如下圖:

用這個篩選的條件去篩選下表中指定的數據是否在這個條件的區間中

然後填入對應的站別
如下圖:

這張圖的編號是要篩選的值要根據篩選的條件填入相對應的站別到代號中

資料筆數一千多行的時候速度很快沒什麼問題但當數據到接近一萬行時速度就變得很慢

以下是我的代碼篩選的條件有增加的需求性所以我將程式設計如下請各位過目

Application.ScreenUpdating = False
Dim 共幾筆資料, 辨識資料起始點, 辨識資料末點, 累加辨識資料數 As Integer: Dim 值1, 值2, 值3 As String
If Not TextBox1.Text = "" And Not TextBox2.Text = "" Then
第幾筆資料 = 3: 值1 = TextBox1.Text & 第幾筆資料: 辨識資料起始點 = 40: 辨識資料末點 = 辨識資料起始點: 累加辨識資料數 = 辨識資料起始點: 值3 = "C" & 辨識資料末點
Do Until Sheets("1012記事").Range(值3).Value = ""
辨識資料末點 = 辨識資料末點 + 1
值3 = "C" & 辨識資料末點
Loop
Dim 起, 訖 As String
Do Until Sheets("會計帳").Range(值1).Value = ""
值2 = TextBox2.Text & 第幾筆資料: 累加辨識資料數 = 辨識資料起始點
Do Until 累加辨識資料數 = 辨識資料末點
起 = "A" & 累加辨識資料數: 訖 = "B" & 累加辨識資料數
If (Sheets("1012記事").Range(起).Value <= (Sheets("會計帳").Range(值1).Value)) Then
If ((Sheets("會計帳").Range(值1).Value) <= Sheets("1012記事").Range(訖).Value) Then
'Sheets("會計帳").Range(值2) = Sheets("1012記事").Range("C" & 累加辨識資料數): Exit Do
Sheets("1012記事").Range("C" & 累加辨識資料數).Copy Destination:=Sheets("會計帳").Range(值2): Exit Do
End If
End If
累加辨識資料數 = 累加辨識資料數 + 1
Loop
'========================================================================
'=====================================================================================
第幾筆資料 = 第幾筆資料 + 1: 值1 = TextBox1.Text & 第幾筆資料
Sleep 100
Loop
MsgBox ("辨識工作完成")