Function Degis(txtGec As String)
    IntVar = InStr(txtGec, "(4")
    Degis = ""
        Do While Not IntVar = 0
            txtGec = Mid(txtGec, IntVar + 1)
          If AlfaSayi(Left(txtGec, InStr(1, txtGec, ")", 2) - 1)) = True Then Degis = Degis & "-" & Left(txtGec, InStr(1, txtGec, ")", 2) - 1)
            IntVar = InStr(txtGec, "(4")
        Loop
   if Degis<>"" then Degis = Mid(Degis, 2)
End Function

Function AlfaSayi(txtGec As String) As Boolean
'hy alfasay?sal bul___________________
    For i = 1 To Len(txtGec)
        If IsNumeric(Mid(txtGec, i, 1)) Or (Mid(txtGec, i, 1)) Like "[a-z]" Then 'alanda sayısal yada alfabetik olmayan değer var m?
            AlfaSayi = True
        Else
            AlfaSayi = False
            Exit For
        End If
    Next i
End Function

Dim BulRS As New ADODB.Recordset
Dim sOrGu, txtBul, txtGec As String
Dim IntVar As Long
 
sOrGu = "select * from Tablo1"
 
    BulRS.Open sOrGu, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
    Do While Not BulRS.EOF
    IntVar = 0
    txtGec = BulRS.Fields(1)
    txtGec = Degis(txtGec)
    If Trim(txtGec) <> "" Then CurrentDb.Execute " insert into Tablo2 (Id,AlinanParca) values (" & BulRS.Fields(0) & _
                                                      ", '" & txtGec & "')"
    BulRS.MoveNext
    Loop

INSERT INTO Tablo2 ( ID, AlinanParca )
SELECT Tablo1.Id, Degis([Tablo1]![AranacakMetin]) AS Eklenecek
FROM Tablo1
WHERE (((Degis([Tablo1]![AranacakMetin]))<>""));

Function Degis(txtGec As String) 'metin değeri alıp işlem yapan fonksiyon oluşturduk
'hy Parca bul___________________
    IntVar = InStr(txtGec, "(4") 'instr() fonksiyonu aradığımız ifadenin metindeki konumunu bulur. Önce "(4" yerini bulduk
    Degis = ""
        Do While Not IntVar = 0 'eğer "(4" yoksa fonksiyon 0 değerini dönderir döngü biter, varsa sıfırdan farklı bir değer alır
            txtGec = Mid(txtGec, IntVar + 1) 'mid(metin, başlama noktası,alınacak uzunluk) burada kayıttaki "(4"üm konumuna 1 ekleyerek "4"ün yerini bulup sonuna kadar aldık
          If InStr(1, txtGec, ")", 2) > 0 Then If AlfaSayi(Left(txtGec, InStr(1, txtGec, ")", 2) - 1)) = True Then Degis = Degis & ";" & Left(txtGec, InStr(1, txtGec, ")", 2) - 1)
          'ilk if eğer ifade ")" ile bitiyorsa 2. if ise ifade sadece alfasayısal ise deiğşkene ekliyor
          'AlfaSayi(Left(txtGec, InStr(1, txtGec, ")", 2) - 1)) = True aşağıda tanımladığımız alfasayısal fonksiyonuna değer yollayıp uygunluğunu denetliyor
            IntVar = InStr(txtGec, "(4") ' bir sonraki "(4" konumunu buluyor
        Loop
    Degis = Mid(Degis, 2) 'en baştaki gereksiz ";" siliyor
End Function

Function AlfaSayi(txtGec As String) As Boolean 'ifade eğer sadece alfa sayısalsa almayı sağlayan fonksiyonu oluşturduk
'hy alfasayısal bul___________________
    For i = 1 To Len(txtGec) ' yukardaki fonksiyonun gönderdiği parçanın uzunlugunu alıyor ve _
                               her bir karakterin ilk karakterden son harfe kadar alfasayısal olıup olmadığına bakıyor
        If IsNumeric(Mid(txtGec, i, 1)) Or (Mid(txtGec, i, 1)) Like "[a-z]" Then 'alanda sayısal yada alfabetik olmayan değer var mı
            'IsNumeric(Mid(txtGec, i, 1)) -->i. sıradaki karakter sayısal mı
            'Mid(txtGec, i, 1)) Like "[a-z]" -->i. sıradaki karakter a-z arasında mı, yani harf mi
            'eğer sayısal yada harf ise sonuç doğru
            AlfaSayi = True
        Else
            AlfaSayi = False 'değilse sonuç yanlış fonksiyonan çık ve üstteki fonksiyona bu degeri alma de
            Exit For
        End If
    Next i 'sonraki harfe geç
End Function

Dim BulRS As New ADODB.Recordset
Dim sOrGu, txtBul, txtGec As String
Dim IntVar, ilkDgr, sonDgr As Long
Dim x As Integer
Dim diziGec() As String
ilkDgr = DCount("*", "Tablo2")'dcount belirli özellikteki kayıt sayısı, tüm kayıtları istediğimizden kriter koymadık
 
sOrGu = "select * from Tablo1" 'tablonun çalıştıracağı sorguyu tanımlıyoruz
 
    BulRS.Open sOrGu, CurrentProject.Connection, adOpenKeyset, adLockOptimistic 'tabloyu tanımlanan sorguya göre açıyoruz
    Do While Not BulRS.EOF 'son kayda kadar kayıtlar arasında ilerliyoruz
    IntVar = 0
    txtGec = Nz(BulRS.Fields(1), "") 'kayıttaki 2. alanı alıyoruz
    txtGec = Degis(txtGec) 'degis() fonksiyonuna yollayarak sadece gerekli parçaları almayı sağlıyoruz
    diziGec = Split(txtGec, ";") 'gerekli alanları parçalara ayırıyoruz _
                                  split() fonksiyonu metni belli kriterlere göre bağımsız parçalara böler _
                                  burada metni her ";" için bölüp diziye aktarıyor
    For x = 0 To UBound(diziGec) 'dizinin ilk değerinden -0 dan- son değerine kadar -ubound()- döngü oluşturur
        If Trim(diziGec(x)) <> "" Then 'eğer dizinin değeri boş değilse "CurrentDb.Execute" komutuyla tabloya ekler
                CurrentDb.Execute " insert into Tablo2 (Id,AlinanParca) values (" & BulRS.Fields(0) & _
                                                          ", '" & diziGec(x) & "')"
        End If
    Next x
    BulRS.MoveNext
    Loop
sonDgr = DCount("*", "Tablo2")
MsgBox (sonDgr - ilkDgr & " tane yeni kayıt eklendi.")