Tách họ tên, địa chỉ, điện thoại ra và gộp lại theo mẫu (5 người xem)

[cuongdv]

Nhờ các anh chị em giúp mình với. Yêu cầu mình đã nói rõ trong file đính kèm
Cảm ơn nhiều

 

[Po_Pikachu]

Sub tach()
Dim i As Byte, j As Byte, k As Byte
For i = 10 To Sheet1.[B6000].End(xlUp).Row
    j = j + ((i Mod 2) = 0) * (i > 11)
    k = i - 9 - (i Mod 2) + j * 2
    Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1) = Left(tachten(Sheet1.Cells(i, "B"), "         "), Len(tachten(Sheet1.Cells(i, "B"), "         ")) - 12)
    Sheet2.Cells(k + 4, (i Mod 2) * 2 + 1) = IIf(tachten(Sheet1.Cells(i, "B"), "         ", 3) = " ", "", ChrW(208) & "T: " & tachten(Sheet1.Cells(i, "B"), "         ", 3))
    Sheet2.Cells(k + 5, (i Mod 2) * 2 + 1) = IIf(tachten(Sheet1.Cells(i, "B"), "         ", 2) = " ", "", ChrW(208) & "C: " & tachten(Sheet1.Cells(i, "B"), "         ", 2))
 
    Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Font.Bold = True
    With Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Resize(3)
        .Borders(7).Weight = 2
        .Borders(8).Weight = 2
        .Borders(9).Weight = 2
        .Borders(10).Weight = 2
    End With
Next
End Sub
 
Function tachten(str As String, Optional Tst As String = ", ", Optional luot As Byte = 1) As String
On Error GoTo Loi
tachten = Split(str, Tst)(luot - 1)
Exit Function
Loi:
 tachten = " "
End Function

Bạn xem file nha!
Thân.

 

[ptm0412]

Po ơi, để có 1 chuỗi 10 ký tự trắng thì dùng thế này cho gọn nè:

Application.Rept(" ", 10)

hoặc gọn hơn nữa:

space(10)

 

[Po_Pikachu]

Em không biết tại sao dùng vào thì nó lổi nên em không dùng được?
Bác thử kiểm tra xem!?
Thân.

 

[ptm0412]

Hè, thử rồi mới dám nói chứ!

Í sorry, Rept() chứ hông phải Rpt()

 

[ndu96081631]

Em không biết tại sao dùng vào thì nó lổi nên em không dùng được?
Bác thử kiểm tra xem!?
Thân.

Lưu ý: Chuổi trong file của tác giả có ký tự đặc biệt: CHAR(160)
Xử lý cái này cũng mệt
Còn hàm này:

Function tachten(str As String, Optional Tst As String = ", ", Optional luot As Byte = 1) As String
On Error GoTo Loi
tachten = Split(str, Tst)(luot - 1)
Exit Function
Loi:
 tachten = " "
End Function

Hình như hơi thừa ---> Chỉ cần On Error Resume Next là được rồi ---> Đàng nào hàm cũng trả về dạng chuổi, nếu có lổi nó đi tiếp và cuối cùng chẳng được gì cả nên trả về chuổi rổng

 

[Po_Pikachu]

Có 1 chổ em không tâm đắt nhất! Là chổ này!

    With Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Resize(3)
        .Borders(7).Weight = 2
        .Borders(8).Weight = 2
        .Borders(9).Weight = 2
        .Borders(10).Weight = 2
    End With

Tại sao lại phải lặp lại quá nhiều lần dòng lệnh này nhỉ? Vậy có cách nào không dùng For mà vẫn nạp được 4 thằng này thành 1 không nhỉ?
Tất nhiên là chỉ dùng 1-2 dòng code thôi.
Thân.

 

[ndu96081631]

Có 1 chổ em không tâm đắt nhất! Là chổ này!

    With Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Resize(3)
        .Borders(7).Weight = 2
        .Borders(8).Weight = 2
        .Borders(9).Weight = 2
        .Borders(10).Weight = 2
    End With

Tại sao lại phải lặp lại quá nhiều lần dòng lệnh này nhỉ? Vậy có cách nào không dùng For mà vẫn nạp được 4 thằng này thành 1 không nhỉ?
Tất nhiên là chỉ dùng 1-2 dòng code thôi.
Thân.

Ah... Được

With Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Resize(3)
  .BorderAround Weight:= 2
End With

Hoặc

With Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Resize(3)
  .BorderAround LineStyle:=7
End With

 

[Po_Pikachu]

Sub thu()
 Dim DS As Range
 Set DS = [A4].CurrentRegion
 DS.Select
[FONT=Courier New][COLOR=#0000bb]Application[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]SendKeys [/COLOR][COLOR=#007700]([/COLOR][COLOR=#dd0000]"^+7^+.^+,^+7"[/COLOR][COLOR=#007700])[/COLOR][/FONT]
End Sub

Sao đoạn code này không hoạt động nhỉ?
Thân.

 

[ndu96081631]

Sub thu()
 Dim DS As Range
 Set DS = [A4].CurrentRegion
 DS.Select
[FONT=Courier New][COLOR=#0000bb]Application[/COLOR][COLOR=#007700].[/COLOR][COLOR=#0000bb]SendKeys [/COLOR][COLOR=#007700]([/COLOR][COLOR=#dd0000]"^+7^+.^+,^+7"[/COLOR][COLOR=#007700])[/COLOR][/FONT]
End Sub

Sao đoạn code này không hoạt động nhỉ?
Thân.

Tôi thử thấy chạy bình thường mà
Code ấy nghiên cứu chơi thôi, chứ ai lại dùng SendKeys
Ẹc... Ẹc...
Tôi dùng cái này:

Sub Thu1()
  With [A4].CurrentRegion
    .Borders.LineStyle = 7
  End With
End Sub

Tại topic này:
http://www.giaiphapexcel.com/forum/showthread.php?t=12709
Còn phải dùng vòng lập, giờ cải tiến khỏi For luôn!

 

[Po_Pikachu]

Không! Máy em nó im re àh? Chỉ dừng lại việc quét chọn thôi! Còn dòng Sendkey thì không thấy hiện tượng gì hết?
Chả hiểu nổi hàm Sendkey này nữa?!
Có vẻ như nó xử lý chậm hơn code VBA thì phải?
Thân.

 

[ndu96081631]

Không! Máy em nó im re àh? Chỉ dừng lại việc quét chọn thôi! Còn dòng Sendkey thì không thấy hiện tượng gì hết?
Chả hiểu nổi hàm Sendkey này nữa?!
Có vẻ như nó xử lý chậm hơn code VBA thì phải?
Thân.

Thử bằng tay coi thế nào:
- Quét chọn vùng nào đó
- Bấm tổ hợp phím Ctrl + Shift 7 , . 7
(Ctrl rồi Shift rồi số 7 rồi dấu phẩy rồi dấu chấm rồi số 7)
Lưu ý: Số 7 nằm dưới dấu &

 

[Po_Pikachu]

Chỉ cần Ctrl + Shift + 7 thôi là được rồi!
Nhưng cái lý là nó không chịu chạy kia!
Thân.

 

[ndu96081631]

Chỉ cần Ctrl + Shift + 7 thôi là được rồi!
Nhưng cái lý là nó không chịu chạy kia!
Thân.

Ah... là bạn kẽ đường bao (không kẽ ở giữa)
Chắc tại có qua vòng lập nên nó "ba trợn" chăng?
Thôi thì dùng cái này cho rồi:

With Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Resize(3)
  .BorderAround Weight:= 2
End With

Rắc rối chi với SendKeys

 

[Po_Pikachu]

Ah... là bạn kẽ đường bao (không kẽ ở giữa)
Chắc tại có qua vòng lập nên nó "ba trợn" chăng?
Thôi thì dùng cái này cho rồi:

With Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Resize(3)
  .BorderAround Weight:= 2
End With

Rắc rối chi với SendKeys

Không có! Em thử nó trên 1 sub riêng mà!

Sub thu()
 Dim DS As Range
 Set DS = [A4].CurrentRegion
 DS.Select
 Application.SendKeys ("^+7")
End Sub

Chỉ tò mò là sao thằng SendKeys không chịu chạy thôi. Chứ dùng BorderAround cho khoẻ chứ! hihi
Vậy là hôm nay học được một chiêu mới rùi!
Thân.

 

[cuongdv]

Sub tach()
Dim i As Byte, j As Byte, k As Byte
For i = 10 To Sheet1.[B6000].End(xlUp).Row
    j = j + ((i Mod 2) = 0) * (i > 11)
    k = i - 9 - (i Mod 2) + j * 2
    Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1) = Left(tachten(Sheet1.Cells(i, "B"), "         "), Len(tachten(Sheet1.Cells(i, "B"), "         ")) - 12)
    Sheet2.Cells(k + 4, (i Mod 2) * 2 + 1) = IIf(tachten(Sheet1.Cells(i, "B"), "         ", 3) = " ", "", ChrW(208) & "T: " & tachten(Sheet1.Cells(i, "B"), "         ", 3))
    Sheet2.Cells(k + 5, (i Mod 2) * 2 + 1) = IIf(tachten(Sheet1.Cells(i, "B"), "         ", 2) = " ", "", ChrW(208) & "C: " & tachten(Sheet1.Cells(i, "B"), "         ", 2))
 
    Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Font.Bold = True
    With Sheet2.Cells(k + 3, (i Mod 2) * 2 + 1).Resize(3)
        .Borders(7).Weight = 2
        .Borders(8).Weight = 2
        .Borders(9).Weight = 2
        .Borders(10).Weight = 2
    End With
Next
End Sub
 
Function tachten(str As String, Optional Tst As String = ", ", Optional luot As Byte = 1) As String
On Error GoTo Loi
tachten = Split(str, Tst)(luot - 1)
Exit Function
Loi:
 tachten = " "
End Function

Bạn xem file nha!
Thân.

Sao em ko chạy đc Mc tách dữ liệu Sh2 đc ah

 

[tuyetbay]

Không chạy được có thể là do bạn đang High Macro rồi.
Bạn DataTools-> Macro -> Security -> chọn Low -> OK -> Rồi khởi động file lại xem.
Thân.

 

[cuongdv]

Không chạy được có thể là do bạn đang High Macro rồi.
.

Khổ cái là mọi thứ vẫn bình thường mới chết chứ
Không hề bị high chút nào cả bạn ah

 

[tuyetbay]

Bạn tải file về có bổ sung hay chỉnh sửa gì trên Sheet1 không?
Thử Recorde 1 Macro xem. Rồi chạy macro mới này xem. Nếu cả Macro mới mà cũng không chạy luôn thì chắc phải Repair Office lại quá.
Chứ code trên đã được test nhiều lần rồi vẫn chạy rất tốt mà!
Thân.