Makroyu koşula bağlı döngüye sokmak

[bordo6181]

Merhaba

Kapalı excellerden veri çekerek çalışan bir sistemim var.
Sistem ilk exceldeki verileri alıyor, eksik verileri 2. excelden eşleştirererek tamamlıyor ve tüm bilgileri 3. excele yazıyor.
Bu döngüye Eğer 2. excelde şu sütunda "Tamamlandı" yazmıyorsa veri çekme diğer satırdan devam et veri çekmeye nasıl diyebiliriz.
@hmtstc tarafından hazırlanan sorgulama kodum bu

Sub sorgulamayeni()
Application.ScreenUpdating = False
basla = Now
Dim son As Long, Dosya_Acikmi As Workbook
Dim target1 As String
eski = WorksheetFunction.Max(3, Cells(Rows.Count, "F").End(3).Row)
ActiveSheet.Unprotect "excelwebtr*"
yol = ThisWorkbook.Path
hedefkitap = "1.xlsm"
On Error Resume Next
Set Dosya_Acikmi = Workbooks(hedefkitap)
On Error GoTo 0
If Not Dosya_Acikmi Is Nothing Then Application.Run "'1.xlsm'!cikisyap"
tümü = yol & "\" & hedefkitap
son = "1048576"
Set con = VBA.CreateObject("adodb.Connection")
con.Open "provider=microsoft.ace.oledb.12.0;data source=" & tümü & ";extended properties=""Excel 12.0;hdr=No"""

k = Cells(Rows.Count, 1).End(3).Row
deger = Cells(k, 1)
    sorgu = "select F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,F11,F12,F13,F14,F15,F16,F17,F18 " & _
      "from[anasayfa$A" & k + 1 & ":V" & son & "]" ' where F2 ='" & targeta & "'" 'and F1 <> " & deger
    Set rs = con.Execute(sorgu)
    Range("A" & k + 1).CopyFromRecordset rs

Call cek1
Call cek2
Call cek3
    Range("Q:Q,T:U").Select
    Range("T1").Activate
    Selection.NumberFormat = "dd/mm/yyyy$hh:mm:ss"
    
    Sheets("liste").Protect "excelwebtr*", _
    DrawingObjects:=True, _
    Contents:=True, _
    Scenarios:=True
    bitir = Now
    
    zaman = bitir - basla
    zaman = Format(zaman, "hh:mm:ss")
    MsgBox "İşleminiz " & zaman & " içerisinde tamamlanmıştır.", vbInformation, "Sorgu tamamlama"
End Sub
Sub cek1()
Dim son As Long, Dosya_Acikmi As Workbook
Dim target1 As String
'On Error Resume Next
eski = WorksheetFunction.Max(3, Cells(Rows.Count, "F").End(3).Row)
ActiveSheet.Unprotect "excelwebtr*"
yol = ThisWorkbook.Path
tümü = yol & "\" & hedefkitap
son = "1048576"
hedefkitap = "2.xlsm"
On Error Resume Next
Set Dosya_Acikmi = Workbooks(hedefkitap)
On Error GoTo 0
If Not Dosya_Acikmi Is Nothing Then Application.Run "'2.xlsm'!cikisyap"

tümü = yol & "\" & hedefkitap
For j = 4 To Cells(Rows.Count, 1).End(3).Row
deger = Cells(j, 1)
test = Cells(j, 10)
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & tümü & ";extended properties=""Excel 12.0;hdr=No"""
    sorgu = "select F9,F10,F11,F12 " & _
      "from[liste$A4:L" & son & "] where F1 =" & deger & " and F6 = '" & test & "'"
     Set rs = con.Execute(sorgu)
    Range("S" & j).CopyFromRecordset rs
Next j
End Sub
Sub cek2()
Dim son As Long, Dosya_Acikmi As Workbook
Dim target1 As String
'On Error Resume Next
eski = WorksheetFunction.Max(3, Cells(Rows.Count, "F").End(3).Row)
ActiveSheet.Unprotect "excelwebtr*"
yol = ThisWorkbook.Path
tümü = yol & "\" & hedefkitap
son = "1048576"
hedefkitap = "21.xlsm"
On Error Resume Next
Set Dosya_Acikmi = Workbooks(hedefkitap)
On Error GoTo 0
If Not Dosya_Acikmi Is Nothing Then Application.Run "'21I.xlsm'!cıkısyap"
'
tümü = yol & "\" & hedefkitap
For j = 4 To Cells(Rows.Count, 1).End(3).Row
deger = Cells(j, 1)
test = Cells(j, 10)
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & tümü & ";extended properties=""Excel 12.0;hdr=No"""
    sorgu = "select F9,F10,F11,F12 " & _
      "from[liste$A4:L" & son & "] where F1 =" & deger & " and F6 = '" & test & "'"
     Set rs = con.Execute(sorgu)
    Range("S" & j).CopyFromRecordset rs
Next j
End Sub
Sub cek3()
Dim son As Long, Dosya_Acikmi As Workbook
Dim target1 As String
'On Error Resume Next
eski = WorksheetFunction.Max(3, Cells(Rows.Count, "F").End(3).Row)
ActiveSheet.Unprotect "excelwebtr*"
yol = ThisWorkbook.Path
tümü = yol & "\" & hedefkitap
son = "1048576"
hedefkitap = "22.xlsm"
On Error Resume Next
Set Dosya_Acikmi = Workbooks(hedefkitap)
On Error GoTo 0
If Not Dosya_Acikmi Is Nothing Then Application.Run "'22.xlsm'!cıkısyap"
'
tümü = yol & "\" & hedefkitap
For j = 4 To Cells(Rows.Count, 1).End(3).Row
deger = Cells(j, 1)
test = Cells(j, 10)
    Set con = VBA.CreateObject("adodb.Connection")
    con.Open "provider=microsoft.ace.oledb.12.0;data source=" & tümü & ";extended properties=""Excel 12.0;hdr=No"""
    sorgu = "select F9,F10,F11,F12 " & _
      "from[liste$A4:L" & son & "] where F1 =" & deger & " and F6 = '" & test & "'"
     Set rs = con.Execute(sorgu)
    Range("S" & j).CopyFromRecordset rs
Next j
End Sub