Hỏi về cách chuyển chữ thường sang chữ nghiêng trong cung một chuỗi văn bản

[hpmongmanh]

Nối text từ các cell có định dạng khác nhau về cùng 1 cell

Mình có một vấn đề muốn xin được chỉ giáo :
VD :
Trong ô A1 gõ "Dân tộc" định dạng font in đậm, in nghiêng hoặc gạch chân ...
Trong ô A2 gõ "Việt Nam" định dạng font in thường
Trong ô A3 gõ "=A1&""&A2
Kết quả trả về "Dân tộc Việt Nam" nhưng lúc này chư "Dân tộc" lại in thường theo định dang của ô A3
Vì vậy mình muốn hỏi có làm cách nào để chuỗi ký tự trong ô A3 vừa có định dạng font của ô A1 và A2
Xin chân thành cảm ơn

Cảm ơn các bạn đã chỉ giáo! bây giờ mình xin được hỏi tiếp rất mong nhận được chỉ giáo sớm:
Nhập ký tự dạng text vào ô A1, A2, A3, ... (mỗi ô là một kiểu định dạng), tại ô C1 sẽ nối A1, A2, A3, ... thành 1 chuỗi (vẫn giữ nguyên định dạng từ các ô được nối). Yêu cầu khi nhập đến đâu thì hiển thị kết quả ngay đến đó, không dùng nút lệnh.
Một lần nữa cảm ơn!

 

[MinhCong]

Mình có một vấn đề muốn xin được chỉ giáo :
VD :
Trong ô A1 gõ "Dân tộc" định dạng font in đậm và in nghiêng
Trong ô A2 gõ "Việt Nam" định dạng font in thường
Trong ô A3 gõ "=A1&""&A2
Kết quả trả về "Dân tộc Việt Nam" nhưng lúc này chư "Dân tộc" lại in thường theo định dang của ô A3
Vì vậy mình muốn hỏi có làm cách nào để chuỗi ký tự trong ô A3 vừa có định dạng font của ô A1 và A2
Xin chân thành cảm ơn

Bạn dùng tạm củ chuối này vậy:

Sub Noichu()
Dim i As Long, enR As Long
Range("C:C").Clear
enR = Sheet1.Range("A65536").End(xlUp).Row
 For i = 1 To enR
    With Cells(i, 3)
        .FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
        .Value = .Value
    End With
    If Cells(i, 1) <> "" Then
      With Cells(i, 3).Characters(Start:=1, Length:=Len(Cells(i, 1))).Font
        .FontStyle = "Bold Italic"
      End With
    Else
    End If
 Next
End Sub

Xem thêm file nhé!

 

[ndu96081631]

Bạn dùng tạm củ chuối này vậy:

Sub Noichu()
Dim i As Long, enR As Long
Range("C:C").Clear
enR = Sheet1.Range("A65536").End(xlUp).Row
 For i = 1 To enR
    With Cells(i, 3)
        .FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
        .Value = .Value
    End With
    If Cells(i, 1) <> "" Then
      With Cells(i, 3).Characters(Start:=1, Length:=Len(Cells(i, 1))).Font
        .FontStyle = "Bold Italic"
      End With
    Else
    End If
 Next
End Sub

Xem thêm file nhé!

Nếu viết thành code, MinhCong nên làm theo hướng thế này:
- Nối chuổi thành KQ
- Xét chuổi KQ, định dạng đoạn đầu giống như chang như cell thứ nhất và đoạn cuối giống y chang cell thứ 2
Có nghìa là 2 cell nguồn định dạng thế nào thì KQ cũng y thế

 

[MinhCong]

Nếu viết thành code, MinhCong nên làm theo hướng thế này:
- Nối chuổi thành KQ
- Xét chuổi KQ, định dạng đoạn đầu giống như chang như cell thứ nhất và đoạn cuối giống y chang cell thứ 2
Có nghìa là 2 cell nguồn định dạng thế nào thì KQ cũng y thế

Theo góp ý của Anh Em điều chỉnh lại code như sau. Anh xem góp ý thêm cho Em nhé!

Sub Noichu()
Dim i As Long, enR As Long
Range("C:C").Clear
enR = Sheet1.Range("A65536").End(xlUp).Row
 For i = 1 To enR
    With Cells(i, 3)
        .FormulaR1C1 = "=RC[-2]&"" ""&RC[-1]"
        .Value = .Value
    End With
    If Cells(i, 1) <> "" Then
      With Cells(i, 3).Characters(Start:=1, Length:=Len(Cells(i, 1))).Font
         .FontStyle = Cells(i, 1).Font.FontStyle
         .ColorIndex = Cells(i, 1).Font.ColorIndex
      End With
      With Cells(i, 3).Characters(Start:=Len(Cells(i, 1)) + 2, Length:=Len(Cells(i, 2))).Font
         .FontStyle = Cells(i, 2).Font.FontStyle
         .ColorIndex = Cells(i, 2).Font.ColorIndex
      End With
    Else
      With Cells(i, 3).Characters(Start:=1, Length:=Len(Cells(i, 2)) + 1).Font
         .FontStyle = Cells(i, 2).Font.FontStyle
         .ColorIndex = Cells(i, 2).Font.ColorIndex
      End With
    End If
 Next
End Sub

 

[ndu96081631]

Theo góp ý của Anh Em điều chỉnh lại code như sau. Anh xem góp ý thêm cho Em nhé!

Tôi thì viết vầy:

Function JoinText(ByVal sRng As Range, ByVal Sep As String) As String
  On Error GoTo NextStp
  If sRng.Count = 1 Then JoinText = sRng.Value: Exit Function
  With WorksheetFunction
    JoinText = Join(.Transpose(sRng), Sep)
    Exit Function
NextStp:
    JoinText = Join(.Transpose(.Transpose(sRng)), Sep)
  End With
End Function

Private Sub MergeStr(ByVal sRng As Range, ByVal Sep As String, ByVal Target As Range)
  Dim Clls As Range, st As Long, i As Long, ifnt As Font
  Target.Value = JoinText(sRng, Sep)
  For Each Clls In sRng
    For i = 1 To Len(Clls)
      With Target.Characters(st + i, 1).Font
        Set ifnt = Clls.Characters(i, 1).Font
        .FontStyle = ifnt.FontStyle
        .Name = ifnt.Name
        .ColorIndex = ifnt.ColorIndex
        .Size = ifnt.Size
        .Underline = ifnt.Underline
        .Strikethrough = ifnt.Strikethrough
        .Superscript = ifnt.Superscript
        .Subscript = ifnt.Subscript
      End With
    Next i
    st = st + Len(Clls) + Len(Sep)
  Next
End Sub

Sub Main()
  Dim i As Long
  With Selection
    For i = 1 To .Rows.Count
      MergeStr Range(.Rows(i).Address), " ", .Offset(, .Columns.Count)(i, 1)
    Next
  End With
End Sub

Thử file đính kèm này xem thế nào nhé

 

[mymapmap]

Cảm Ơn Bác ndu96081631 đã có code rất hay để hoc hỏi. Nhưng em nghi Bác có thể viết dưới dạng như một hàm trong excel được không? để e có thể gọi nó bất cứ chỗ nào không phải nhấn nút. gì nhu cầu của e chỉ có 2 cell thôi
VD: = NoiChuoi(A1:A2)
Xin Cảm ơn!

 

[ndu96081631]

Cảm Ơn Bác ndu96081631 đã có code rất hay để hoc hỏi. Nhưng em nghi Bác có thể viết dưới dạng như một hàm trong excel được không? để e có thể gọi nó bất cứ chỗ nào không phải nhấn nút. gì nhu cầu của e chỉ có 2 cell thôi
VD: = NoiChuoi(A1:A2)
Xin Cảm ơn!

Không được đâu!
Bạn nên biết rằng:
- Hàm chỉ có chức năng tính toán và xuất ra 1 kết quả nào đó
- Hàm không có chức năng định dạng hoặc thay đổi thuộc tính của cell ---> Công việc này thích hợp với các THỦ TỤC (gọi là Sub)

 

[chickenlove258]

Tôi thì viết vầy:

Function JoinText(ByVal sRng As Range, ByVal Sep As String) As String
  On Error GoTo NextStp
  If sRng.Count = 1 Then JoinText = sRng.Value: Exit Function
  With WorksheetFunction
    JoinText = Join(.Transpose(sRng), Sep)
    Exit Function
NextStp:
    JoinText = Join(.Transpose(.Transpose(sRng)), Sep)
  End With
End Function

Private Sub MergeStr(ByVal sRng As Range, ByVal Sep As String, ByVal Target As Range)
  Dim Clls As Range, st As Long, i As Long, ifnt As Font
  Target.Value = JoinText(sRng, Sep)
  For Each Clls In sRng
    For i = 1 To Len(Clls)
      With Target.Characters(st + i, 1).Font
        Set ifnt = Clls.Characters(i, 1).Font
        .FontStyle = ifnt.FontStyle
        .Name = ifnt.Name
        .ColorIndex = ifnt.ColorIndex
        .Size = ifnt.Size
        .Underline = ifnt.Underline
        .Strikethrough = ifnt.Strikethrough
        .Superscript = ifnt.Superscript
        .Subscript = ifnt.Subscript
      End With
    Next i
    st = st + Len(Clls) + Len(Sep)
  Next
End Sub

Sub Main()
  Dim i As Long
  With Selection
    For i = 1 To .Rows.Count
      MergeStr Range(.Rows(i).Address), " ", .Offset(, .Columns.Count)(i, 1)
    Next
  End With
End Sub

Thử file đính kèm này xem thế nào nhé

Xin Chào Bác NDU, Cũng với code của Bác nhưng em muốn thay thế khoảng trắng bằng kí tự Char(10) thì cần cân chỉnh gì ạ, em đạ thử nhiều lần với vốn kiến thức ít ỏi của em mà cũng chưa được. Nay mạo muo5i nhờ Bác giúp thêm chút nữa.

 

[ndu96081631]

Xin Chào Bác NDU, Cũng với code của Bác nhưng em muốn thay thế khoảng trắng bằng kí tự Char(10) thì cần cân chỉnh gì ạ, em đạ thử nhiều lần với vốn kiến thức ít ỏi của em mà cũng chưa được. Nay mạo muo5i nhờ Bác giúp thêm chút nữa.

Cú pháp của Sub MergeStr là:
MergeStr (vùng dữ liệu, dấu phân cách, nơi đặt kết quả)
Vậy Char(10) của bạn là đặt vào chỗ màu đỏ ấy, tức khi áp dụng vào Sub Main ta sẽ viết

Sub Main()
  Dim i As Long
  With Selection
    For i = 1 To .Rows.Count
      MergeStr Range(.Rows(i).Address), [COLOR=#ff0000]Chr(10)[/COLOR], .Offset(, .Columns.Count)(i, 1)
    Next
  End With
End Sub

Lưu ý: Trên bảng tính ta viết Char(10) còn trong VBA thì viết Chr(10) nha (không có chữ a)

 

[autokiss]

Code nối chữ hay quá!