Metin içindeki virgülle ayrılan verileri farklı satıra yazma

1 2 3
05/05/2020, 00:21

POWER

Aynı tabloda işlemin yapılmasını istiyorsanız tüm kodları silin aşağıdaki kodu yapıştırın...
Option Compare Database
Private Sub Komut0_Click()
Dim Sql As String
Dim rs, rt As DAO.Recordset
Set DB = CurrentDb()

SQL = "SELECT * FROM Tablo1"
Set rs = DB.OpenRecordset(SQL)
SQL = "SELECT * FROM Tablo1"
Set rt = DB.OpenRecordset(SQL)

rs.MoveFirst
Do Until rs.EOF
   ARA = rs!kisiler
  
10:
   A1 = InStr(ARA, ",")
   If A1 > 0 Then
      YENIISIM = Trim(Left(ARA, A1 - 1))
      ARA = Mid(ARA, A1 + 1)
      rt.AddNew
      rt!sınıf = rs!sınıf
      rt!kisiler = YENIISIM
      rt![sınıf durumu] = rs![sınıf durumu]
      rt.Update
      GoTo 10
   End If
   If A1 = 0 Then
      YENIISIM = Trim(ARA)
      rt.AddNew
      rt!sınıf = rs!sınıf
      rt!kisiler = YENIISIM
      rt![sınıf durumu] = rs![sınıf durumu]
      rt.Update
   End If
rs.Delete
rs.MoveNext
Loop

MsgBox "Tablo dolduruldu..."
End Sub
05/05/2020, 15:38

sfenksturk

Cevaplarınız için teşekkür ederim. sorun yaşadığım örneği ekte gönderiyorum. ben kişileri tek bir virgülle ayrı olarak belirtmiştim. ancak üzerinde çalıştığım projede kişiler ''----------------' 16 adet tire ile ayrı. sizin örneğinizi bu şekilde değiştirdiğimde her bir satır için birer tane boş satır oluşturuyor. onun çözümünü bulamadım.
05/05/2020, 16:26

POWER

Option Compare Database

Private Sub Komut0_Click()
Dim Sql As String
Dim rs, rt As DAO.Recordset
Set DB = CurrentDb()

SQL = "SELECT * FROM Tablo1"
Set rs = DB.OpenRecordset(SQL)
SQL = "SELECT * FROM YENITABLO"
Set rt = DB.OpenRecordset(SQL)

rs.MoveFirst
Do Until rs.EOF
  ARA = rs!kisiler
 
10:
  A1 = InStr(ARA, "----------------")
                   
  If A1 > 0 Then
      YENIISIM = Trim(Left(ARA, A1 - 1))
      A2 = InStr(YENIISIM, ")")
      YENIISIM = Trim(Mid(YENIISIM, A2 + 1))
      ARA = Trim(Mid(ARA, A1 + 16))
      rt.AddNew
      rt!sınıf = rs!sınıf
      rt!kisiler = YENIISIM
      rt![sınıf durumu] = rs![sınıf durumu]
      rt.Update
      GoTo 10
  End If
 
rs.MoveNext
Loop

MsgBox "Tablo dolduruldu..."
End Sub
Kodu aşağıdaki ile değiştirin.
05/05/2020, 16:54

accessman

teşekkürler sn. @POWER
05/05/2020, 18:02

sfenksturk

sn. @POWER cevabınız için teşekkür ederim.
1 2 3