Tách tên ra khỏi số điện thoại

[hongphuong1997]

Em có bài như file đính kèm
Nhờ anh chị viết code giúp
Em xin cảm ơn

 

[Ba Tê]

Em có bài như file đính kèm
Nhờ anh chị viết code giúp
Em xin cảm ơn

Giải thích khó hiểu quá.
Dữ liệu từ 1 cột A. Kết quả thành 2 cột A, B giống như K, L ?

Public Sub sGpe1()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tmp
sArr = Range("A1", Range("A60000").End(xlUp)).Value
R = UBound(sArr)
ReDim dArr(1 To R / 6, 1 To 2)
For I = 1 To R Step 6
    Tmp = Split(sArr(I, 1), " ")
    K = K + 1
    dArr(K, 1) = Left(sArr(I, 1), Len(sArr(I, 1)) - Len(Tmp(UBound(Tmp))) - 1)
    dArr(K, 2) = sArr(I, 1)
Next I
Range("A1").Resize(R).ClearContents
Range("A1").Resize(K, 2) = dArr
End Sub

Hay là:
Dữ liệu từ cột A, những dòng có tên thì tách bỏ SĐT, dữ liệu cột A chuyển sang cột B?

 

[saobekhonglac]

Em có bài như file đính kèm
Nhờ anh chị viết code giúp
Em xin cảm ơn

Có thể dùng hàm:

L3=INDIRECT(ADDRESS(1+6*(ROW(A1)-1),1))
K3=TRIM(LEFT(L3,LEN(L3)-11))

 

[CHAOQUAY]

Em có bài như file đính kèm
Nhờ anh chị viết code giúp
Em xin cảm ơn

Chạy thử code này xem sao

Sub TachTen_Sdt()
Dim DanhSach
Dim Kq
Dim i, j
With Sheet2
    DanhSach = .Range("a1", .Range("a1000000").End(xlUp))
End With
ReDim Kq(1 To (UBound(DanhSach) + 1) \ 6, 1 To 2)
For i = 1 To UBound(DanhSach) Step 6
    j = j + 1
    Kq(j, 2) = DanhSach(i, 1)
    Kq(j, 1) = Trim(Left(Kq(j, 2), Len(Kq(j, 2)) - 10))
Next i
With Sheet1
    .UsedRange.ClearContents
    .Range("a1").Resize(UBound(Kq), UBound(Kq, 2)) = Kq
End With
End Sub

 

[hongphuong1997]

Em xin cảm ơn tất cả các anh @Ba Tê , @CHAOQUAY , @saobekhonglac tất cả đều đúng hết các anh à

 

[vanthinh3101]

Góp vui bằng công thức:

L3=OFFSET(A1,(ROW(A1)-1)*5,)
K3=TRIM(RIGHT(SUBSTITUTE(N3," ",REPT(" ",100)),100))

 

[hongphuong1997]

Giải thích khó hiểu quá.
Dữ liệu từ 1 cột A. Kết quả thành 2 cột A, B giống như K, L ?

Public Sub sGpe1()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tmp
sArr = Range("A1", Range("A60000").End(xlUp)).Value
R = UBound(sArr)
ReDim dArr(1 To R / 6, 1 To 2)
For I = 1 To R Step 6
    Tmp = Split(sArr(I, 1), " ")
    K = K + 1
    dArr(K, 1) = Left(sArr(I, 1), Len(sArr(I, 1)) - Len(Tmp(UBound(Tmp))) - 1)
    dArr(K, 2) = sArr(I, 1)
Next I
Range("A1").Resize(R).ClearContents
Range("A1").Resize(K, 2) = dArr
End Sub

Hay là:
Dữ liệu từ cột A, những dòng có tên thì tách bỏ SĐT, dữ liệu cột A chuyển sang cột B?

Anh @Ba Tê bài này sảy ra tình huống khác trước
Em nhờ anh chỉnh sửa code giúp em với anh nhé
Em cảm ơn anh!

 

[snow25]

Anh @Ba Tê bài này sảy ra tình huống khác trước
Em nhờ anh chỉnh sửa code giúp em với anh nhé
Em cảm ơn anh!

Em Chạy thử cái này xem đúng không nhé.Sửa chút ít của bác @Ba Tê

Public Sub sGpe1()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tmp
sArr = Range("A1", Range("A60000").End(xlUp)).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 2)
      Tmp = Split(sArr(1, 1), " ")
      dArr(1, 1) = Left(sArr(1, 1), Len(sArr(1, 1)) - Len(Tmp(UBound(Tmp))) - 1)
      dArr(1, 2) = sArr(1, 1)
      K = 1
For I = 2 To R - 1
  If sArr(I, 1) <> Empty Then
    If InStr(1, sArr(I + 1, 1), sArr(I, 1)) Then
       K = K + 1
       dArr(K, 1) = sArr(I, 1)
       dArr(K, 2) = sArr(I + 1, 1)
       I = I + 1
    End If
 End If
Next I
Range("A1").Resize(R).ClearContents
Range("A1").Resize(K, 2) = dArr
End Sub

 

[hongphuong1997]

Em Chạy thử cái này xem đúng không nhé.Sửa chút ít của bác @Ba Tê

Public Sub sGpe1()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tmp
sArr = Range("A1", Range("A60000").End(xlUp)).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 2)
      Tmp = Split(sArr(1, 1), " ")
      dArr(1, 1) = Left(sArr(1, 1), Len(sArr(1, 1)) - Len(Tmp(UBound(Tmp))) - 1)
      dArr(1, 2) = sArr(1, 1)
      K = 1
For I = 2 To R - 1
  If sArr(I, 1) <> Empty Then
    If InStr(1, sArr(I + 1, 1), sArr(I, 1)) Then
       K = K + 1
       dArr(K, 1) = sArr(I, 1)
       dArr(K, 2) = sArr(I + 1, 1)
       I = I + 1
    End If
End If
Next I
Range("A1").Resize(R).ClearContents
Range("A1").Resize(K, 2) = dArr
End Sub

Em Chạy thử cái này xem đúng không nhé.Sửa chút ít của bác @Ba Tê

Public Sub sGpe1()
Dim sArr(), dArr(), I As Long, K As Long, R As Long, Tmp
sArr = Range("A1", Range("A60000").End(xlUp)).Value
R = UBound(sArr)
ReDim dArr(1 To R, 1 To 2)
      Tmp = Split(sArr(1, 1), " ")
      dArr(1, 1) = Left(sArr(1, 1), Len(sArr(1, 1)) - Len(Tmp(UBound(Tmp))) - 1)
      dArr(1, 2) = sArr(1, 1)
      K = 1
For I = 2 To R - 1
  If sArr(I, 1) <> Empty Then
    If InStr(1, sArr(I + 1, 1), sArr(I, 1)) Then
       K = K + 1
       dArr(K, 1) = sArr(I, 1)
       dArr(K, 2) = sArr(I + 1, 1)
       I = I + 1
    End If
End If
Next I
Range("A1").Resize(R).ClearContents
Range("A1").Resize(K, 2) = dArr
End Sub

Anh ơi, được rồi, chuẩn quá anh ơi
Em cảm ơn anh @snow25