Sub GhepChuoiThongTin()
Dim OutCol As Range, Row As Range, Cl As Range
Dim Temp As String, Sep As String: Dim i As Long
Const TBao As String = "Thông Báo' "
On Error GoTo Loi
' --- Kiem tra workbook --- '
1 If Application.Workbooks.Count = 0 Then Exit Sub '??
' --- Kiem tra vung chon --- '
2 If (Selection Is Nothing) Or (TypeName(Selection) <> "Range") Then
MsgBox "1 Ban chua chon vùng du liêu cân ghép ô.", vbCritical, TBao
Exit Sub
End If
3 If Selection.Areas.Count > 1 Then
MsgBox "2 Ban da chon nhiêu vùng không liên kê, chi duoc chon 1 vùng duy nhât.", vbExclamation, TBao
Exit Sub
End If
' --- Nhâp ký tu ngan cách --- '
4 Sep = InputBox("Nhâp ký tu chèn giua các phân tu duoc ghép:" & vbCrLf & _
"(Vi du: dâu cách, dâu phay, dâu gach...)", "Tùy chon ký tu", " ")
If Sep = vbNullString Then Sep = " "
' --- Chon cot ket qua --- '
On Error Resume Next
5 Set OutCol = Application.InputBox("Chon côt dê ghi kêt qua (chi chon 1 côt):", "Chon côt kêt qua", Type:=8)
On Error GoTo Loi
6 If OutCol.Columns.Count > 1 Then
MsgBox "Chi duoc chon 1 côt duy nhât.", vbExclamation, "Thông báo!"
Exit Sub
End If
' --- Ghep tung hang (theo thu tu, khong phu thuoc vi tri that) --- '
i = 0
7 For Each Row In Selection.Rows
Temp = ""
For Each Cl In Row.Cells
If Trim(Cl.Text) <> "" Then Temp = Temp & Cl.Text & Sep
Next Cl
If Len(Temp) > 0 Then Temp = Left(Temp, Len(Temp) - Len(Sep))
OutCol.Cells(1, 1).Offset(i, 0).Value = "" & Temp
i = i + 1
Next Row
MsgBox "Da ghép xong du liêu vào côt " & OutCol.Address(False, False) & ".", vbInformation, "Hoàn tât!"
Exit Sub
Loi:
MsgBox "Có lôi xây ra trong quá trình ghép ô!", vbCritical, "Dòng Lôi: " & Erl
End SubIf Len(temp) > 0 Then
Application.InputBox Type:=8
Anh gợi ý cho em bẫy lỗi như nào với ạ?
Câu lệnh mang chỉ số dòng là 7 đó có nội dung là
Sub GhepVungONhieuCot()
Dim sRng As Range, Cls As Range, RgKH As Range
Dim Dg As Long
Const FC As String = "; "
Dim TmpStr As String
Dim Arr() As String
On Error GoTo LoiCT
' Nhập vùng dữ liệu '
Set sRng = Application.InputBox("Nhập vùng gồm >= 2 cột", "$D$4:$G$9", Type:=8)
If sRng Is Nothing Then
MsgBox "Bạn đã hủy hoặc nhập sai vùng!"
Exit Sub
End If
If sRng.Columns.Count < 2 Then
MsgBox "Bạn cần chọn ít nhất 2 cột!", vbExclamation, "Bye!"
Exit Sub
End If
' Nhập ô kết quả '
Set RgKH = Application.InputBox("Nhập ô hiển kết quả", "$W$2", Type:=8)
If RgKH Is Nothing Then Exit Sub
ReDim Arr(1 To sRng.Rows.Count, 1 To 1)
' Ghép dữ liệu từng dòng '
For Dg = 1 To sRng.Rows.Count
TmpStr = ""
For Each Cls In sRng.Rows(Dg).Cells
If Trim(Cls.Text) <> "" Then TmpStr = TmpStr & Cls.Text & FC
Next Cls
If Len(TmpStr) > 0 Then TmpStr = Left(TmpStr, Len(TmpStr) - Len(FC)) ' bỏ dấu ; cuối
Arr(Dg, 1) = TmpStr
Next Dg
' Xuất kết quả '
RgKH.Resize(sRng.Rows.Count).Value = Arr
Exit Sub
LoiCT:
MsgBox "Có lỗi xảy ra: " & Err.Description, vbCritical
End Sub
Application.DisplayAlerts = False
On Error Resume Next
Set RgKH = Application.InputBox("Nhập ô hiển kết quả", ,"$W$2", Type:=8)
Application.DisplayAlerts = True
If RgKH Is Nothing Then Exit Sub
