HocVBAExcel
Thành viên mới

- Tham gia
- 17/4/15
- Bài viết
- 40
- Được thích
- 1
- Giới tính
- Nam
Sub Tinh()
Dim i, j, m, k As Long, sArr
sArr = Range([B4], [B65000].End(xlUp)).Resize(, 3)
ReDim dArr(1 To UBound(sArr), 1 To 3)
For i = 1 To UBound(sArr)
k = k + 1
dArr(k, 2) = sArr(i, 2)
If sArr(i, 3) = "" Then
dArr(k, 1) = sArr(i, 1)
For j = 1 To Len(sArr(i, 2))
If Mid(sArr(i, 2), j, 1) Like "#" Then dArr(k, 3) = dArr(k, 3) & Mid(sArr(i, 2), j, 1)
Next j
Else
dArr(k, 3) = sArr(i, 3)
If sArr(i, 2) <> "" Then
For m = 1 To Len(sArr(i, 2))
If Mid(sArr(i, 2), m, 1) Like "#" Then dArr(k, 1) = dArr(k, 1) & Mid(sArr(i, 2), m, 1)
Next m
dArr(k, 1) = sArr(i, 1) & "-" & dArr(k, 1)
Else
dArr(k, 1) = sArr(i, 1)
End If
End If
Next i
[F4:H65000].ClearContents
[F4].Resize(k, 3).Value = dArr
End Sub
Đúng rồi bạn mình Cám ơn nhiềuBạn kiểm tra lại F8,F9 đâu có như bạn nói việc ghép nối phải như F10, F12Mã:Sub Tinh() Dim i, j, m, k As Long, sArr sArr = Range([B4], [B65000].End(xlUp)).Resize(, 3) ReDim dArr(1 To UBound(sArr), 1 To 3) For i = 1 To UBound(sArr) k = k + 1 dArr(k, 2) = sArr(i, 2) If sArr(i, 3) = "" Then dArr(k, 1) = sArr(i, 1) For j = 1 To Len(sArr(i, 2)) If Mid(sArr(i, 2), j, 1) Like "#" Then dArr(k, 3) = dArr(k, 3) & Mid(sArr(i, 2), j, 1) Next j Else dArr(k, 3) = sArr(i, 3) If sArr(i, 2) <> "" Then For m = 1 To Len(sArr(i, 2)) If Mid(sArr(i, 2), m, 1) Like "#" Then dArr(k, 1) = dArr(k, 1) & Mid(sArr(i, 2), m, 1) Next m dArr(k, 1) = sArr(i, 1) & "-" & dArr(k, 1) Else dArr(k, 1) = sArr(i, 1) End If End If Next i [F4:H65000].ClearContents [F4].Resize(k, 3).Value = dArr End Sub