Hỗ trợ nối dữ liệu giữ nguyên bản sắc

Tình nghĩa giang hồ · 23/4/22

Em chào anh chị, em có vấn đề này nhờ anh chị giúp đỡ.
Em có 3 cột dữ liệu: dữ liệu 1, kiểu nối, dữ liệu 2. Em mong muốn dữ liệu có định dạng gì (in đậm, in nghiêng) và màu sắc (đỏ, cam vàng....). Khi kết hợp lại thì giữ nguyên, kiểu dạng hòa nhập mà không hòa tan đó anh chị.
Trường hợp, nếu không làm được kiểu đa dạng như thế, thì giúp đỡ dùm em, dữ liệu 1: bình thường, kết hợp với dữ liệu 2: In đậm + một màu đơn sắc nào đó cũng được.
Em cảm ơn anh chị nhiều.

Phuocam · 23/4/22

Tình nghĩa giang hồ đã viết:
Em chào anh chị, em có vấn đề này nhờ anh chị giúp đỡ.
Em có 3 cột dữ liệu: dữ liệu 1, kiểu nối, dữ liệu 2. Em mong muốn dữ liệu có định dạng gì (in đậm, in nghiêng) và màu sắc (đỏ, cam vàng....). Khi kết hợp lại thì giữ nguyên, kiểu dạng hòa nhập mà không hòa tan đó anh chị.
Trường hợp, nếu không làm được kiểu đa dạng như thế, thì giúp đỡ dùm em, dữ liệu 1: bình thường, kết hợp với dữ liệu 2: In đậm + một màu đơn sắc nào đó cũng được.
Em cảm ơn anh chị nhiều.

Tôi không biết sử dụng hàm, nhưng sub có thể làm được.

.

Tình nghĩa giang hồ · 23/4/22

Phuocam đã viết:
Tôi không biết sử dụng hàm, nhưng sub có thể làm được.

.

Dạ không quan trọng phương pháp anh, cách nào giải quyết được vấn đề là đều là cách hay cả mà. Cảm ơn anh.

duy199922 · 23/4/22

Xem thử xem thế nào bạn nhé! Có thể thay đoạn code này vào nếu dữ liệu ở ô AA1 không phải định dạng mặc định!

Mã:

Sub Drop()
Dim lsr, i, o, j, q As Long
lsr = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lsr
    Range("E" & i).Value = Range("A" & i).Value2 & Range("B" & i).Value2 & Range("C" & i).Value2
    o = Len(Range("A" & i).Value)
    j = Len(Range("C" & i).Value)
    q = Len(Range("B" & i).Value)
 
    Range("E" & i).Select
    ActiveCell.FormulaR1C1 = Range("E" & i).Value
    With ActiveCell.Characters(o, q).Font
        .Name = Range("B" & i).Font.Name
        .FontStyle = Range("B" & i).Font.FontStyle
        .Size = Range("B" & i).Font.Size
        .Strikethrough = Range("B" & i).Font.Strikethrough
        .Superscript = Range("B" & i).Font.Superscript
        .Subscript = Range("B" & i).Font.Subscript
        .OutlineFont = False
        .Shadow = False
        .Underline = Range("B" & i).Font.Underline
        .Color = Range("B" & i).Font.Color
        .TintAndShade = Range("B" & i).Font.TintAndShade
        .ThemeFont = Range("B" & i).Font.ThemeFont
    End With
   With ActiveCell.Characters(Start:=1, Length:=9).Font
        .Name = Range("A" & i).Font.Name
        .FontStyle = Range("A" & i).Font.FontStyle
        .Size = Range("A" & i).Font.Size
        .Strikethrough = Range("A" & i).Font.Strikethrough
        .Superscript = Range("A" & i).Font.Superscript
        .Subscript = Range("A" & i).Font.Subscript
        .OutlineFont = False
        .Shadow = False
        .Underline = Range("A" & i).Font.Underline
        .Color = Range("A" & i).Font.Color
        .TintAndShade = Range("A" & i).Font.TintAndShade
        .ThemeFont = Range("A" & i).Font.ThemeFont
    End With
    With ActiveCell.Characters(Start:=o + q + 1, Length:=j).Font
        .Name = Range("C" & i).Font.Name
        .FontStyle = Range("C" & i).Font.FontStyle
       .Size = Range("C" & i).Font.Size
        .Strikethrough = Range("C" & i).Font.Strikethrough
        .Superscript = Range("C" & i).Font.Superscript
        .Subscript = Range("C" & i).Font.Subscript
        .OutlineFont = False
        .Shadow = False
        .Underline = Range("C" & i).Font.Underline
        .Color = Range("C" & i).Font.Color
        .TintAndShade = Range("C" & i).Font.TintAndShade
        .ThemeFont = Range("C" & i).Font.ThemeFont
   End With
Next
End Sub

Tình nghĩa giang hồ · 23/4/22

duy199922 đã viết:

Xem thử xem thế nào bạn nhé! Có thể thay đoạn code này vào nếu dữ liệu ở ô AA1 không phải định dạng mặc định!

Mã:

Sub Drop()
Dim lsr, i, o, j, q As Long
lsr = Range("A" & Rows.Count).End(xlUp).Row

For i = 2 To lsr
    Range("E" & i).Value = Range("A" & i).Value2 & Range("B" & i).Value2 & Range("C" & i).Value2
    o = Len(Range("A" & i).Value)
    j = Len(Range("C" & i).Value)
    q = Len(Range("B" & i).Value)
 
    Range("E" & i).Select
    ActiveCell.FormulaR1C1 = Range("E" & i).Value
    With ActiveCell.Characters(o, q).Font
        .Name = Range("B" & i).Font.Name
        .FontStyle = Range("B" & i).Font.FontStyle
        .Size = Range("B" & i).Font.Size
        .Strikethrough = Range("B" & i).Font.Strikethrough
        .Superscript = Range("B" & i).Font.Superscript
        .Subscript = Range("B" & i).Font.Subscript
        .OutlineFont = False
        .Shadow = False
        .Underline = Range("B" & i).Font.Underline
        .Color = Range("B" & i).Font.Color
        .TintAndShade = Range("B" & i).Font.TintAndShade
        .ThemeFont = Range("B" & i).Font.ThemeFont
    End With
   With ActiveCell.Characters(Start:=1, Length:=9).Font
        .Name = Range("A" & i).Font.Name
        .FontStyle = Range("A" & i).Font.FontStyle
        .Size = Range("A" & i).Font.Size
        .Strikethrough = Range("A" & i).Font.Strikethrough
        .Superscript = Range("A" & i).Font.Superscript
        .Subscript = Range("A" & i).Font.Subscript
        .OutlineFont = False
        .Shadow = False
        .Underline = Range("A" & i).Font.Underline
        .Color = Range("A" & i).Font.Color
        .TintAndShade = Range("A" & i).Font.TintAndShade
        .ThemeFont = Range("A" & i).Font.ThemeFont
    End With
    With ActiveCell.Characters(Start:=o + q + 1, Length:=j).Font
        .Name = Range("C" & i).Font.Name
        .FontStyle = Range("C" & i).Font.FontStyle
       .Size = Range("C" & i).Font.Size
        .Strikethrough = Range("C" & i).Font.Strikethrough
        .Superscript = Range("C" & i).Font.Superscript
        .Subscript = Range("C" & i).Font.Subscript
        .OutlineFont = False
        .Shadow = False
        .Underline = Range("C" & i).Font.Underline
        .Color = Range("C" & i).Font.Color
        .TintAndShade = Range("C" & i).Font.TintAndShade
        .ThemeFont = Range("C" & i).Font.ThemeFont
   End With
Next
End Sub

Em cảm ơn anh.
Em đã test qua, Code này còn thiếu 1 tí nữa là đạt sự hoàn hảo, tối ưu.
Hiện tại nó vẫn còn vướng 1 tí, là dữ liệu khu vực A nó chỉ làm được 1/2 không biết có phải ký tự dài quá nó ko làm được không ?

duy199922 · 23/4/22

Tình nghĩa giang hồ đã viết:
Em cảm ơn anh.
Em đã test qua, Code này còn thiếu 1 tí nữa là đạt sự hoàn hảo, tối ưu.
Hiện tại nó vẫn còn vướng 1 tí, là dữ liệu khu vực A nó chỉ làm được 1/2 không biết có phải ký tự dài quá nó ko làm được không ?

Thay lenght:=9 thành lenght:=o là được

Nhattanktnn · 23/4/22

Tình nghĩa giang hồ đã viết:
Em cảm ơn anh.
Em đã test qua, Code này còn thiếu 1 tí nữa là đạt sự hoàn hảo, tối ưu.
Hiện tại nó vẫn còn vướng 1 tí, là dữ liệu khu vực A nó chỉ làm được 1/2 không biết có phải ký tự dài quá nó ko làm được không ?

Thay đổi vùng muốn nối trong code, đã ghi chú rõ.
Dữ liệu nhiều có thể bị chậm (tất nhiên kiểu này chắc không ai nối nhiều)
Code không thay xóa khoảng trống dư thừa, chỉ làm nhiệm vụ lấy format mà thôi

Mã:

Option Explicit

Sub JoinKeepFormat()
Dim I&, J&, K&, Rws&, L&, Col&, Leng&, Rng As Range, dCell As Range, sCellProp As Object
Application.ScreenUpdating = False
With Sheets("Sheet1")
    Set Rng = .Range("A2:C109") 'Thay doi vung mong muon
    Rws = Rng.Rows.Count
    Col = Rng.Columns.Count
    For I = 1 To Rws
        Set dCell = Rng(I, 1).Offset(, Col): dCell.Clear
        For J = 1 To Col
            If dCell.Value <> "" Then
                dCell.Value = dCell.Value & Space(1) & Rng(I, J)
            Else
                dCell.Value = Rng(I, J)
            End If
        Next
        K = 1: L = 0
        For J = 1 To Len(dCell.Value)
            L = L + 1
            Leng = Len(Rng(I, K))
            If J > Leng Then
                K = K + 1: J = 0
                If K > Col Then Exit For
            Else
                Set sCellProp = Rng(I, K).Characters(J, 1).Font
                With dCell.Characters(L, 1).Font
                    .Name = sCellProp.Name
                    .FontStyle = sCellProp.FontStyle
                    .Size = sCellProp.Size
                    .Strikethrough = sCellProp.Strikethrough
                    .Superscript = sCellProp.Superscript
                    .Subscript = sCellProp.Subscript
                    .OutlineFont = sCellProp.OutlineFont
                    .Underline = sCellProp.Underline
                    .Color = sCellProp.Color
                End With
            End If
        Next
    Next
End With
Application.ScreenUpdating = True
End Sub

Vẫn còn chưa hoàn thiện lắm với một số trường hợp, tuy nhiên trước mắt cứ như vậy đã

Tình nghĩa giang hồ · 23/4/22

Nhattanktnn đã viết:

Thay đổi vùng muốn nối trong code, đã ghi chú rõ.
Dữ liệu nhiều có thể bị chậm (tất nhiên kiểu này chắc không ai nối nhiều)
Code không thay xóa khoảng trống dư thừa, chỉ làm nhiệm vụ lấy format mà thôi

Mã:

Option Explicit

Sub JoinKeepFormat()
Dim I&, J&, K&, Rws&, L&, Col&, Leng&, Rng As Range, dCell As Range, sCellProp As Object
Application.ScreenUpdating = False
With Sheets("Sheet1")
    Set Rng = .Range("A2:C109") 'Thay doi vung mong muon
    Rws = Rng.Rows.Count
    Col = Rng.Columns.Count
    For I = 1 To Rws
        Set dCell = Rng(I, 1).Offset(, Col): dCell.Clear
        For J = 1 To Col
            If dCell.Value <> "" Then
                dCell.Value = dCell.Value & Space(1) & Rng(I, J)
            Else
                dCell.Value = Rng(I, J)
            End If
        Next
        K = 1: L = 0
        For J = 1 To Len(dCell.Value)
            L = L + 1
            Leng = Len(Rng(I, K))
            If J > Leng Then
                K = K + 1: J = 0
                If K > Col Then Exit For
            Else
                Set sCellProp = Rng(I, K).Characters(J, 1).Font
                With dCell.Characters(L, 1).Font
                    .Name = sCellProp.Name
                    .FontStyle = sCellProp.FontStyle
                    .Size = sCellProp.Size
                    .Strikethrough = sCellProp.Strikethrough
                    .Superscript = sCellProp.Superscript
                    .Subscript = sCellProp.Subscript
                    .OutlineFont = sCellProp.OutlineFont
                    .Underline = sCellProp.Underline
                    .Color = sCellProp.Color
                End With
            End If
        Next
    Next
End With
Application.ScreenUpdating = True
End Sub

Vẫn còn chưa hoàn thiện lắm với một số trường hợp, tuy nhiên trước mắt cứ như vậy đã

Cảm ơn cách, code này ok, đạt mong muốn của em rồi anh. Trường hợp chậm thì em làm 1 cốc trà thôi ạ, không vấn đề gì. Em cảm ơn anh nhiều.

Hỗ trợ nối dữ liệu giữ nguyên bản sắc

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu

File đính kèm

Phuocam

Thành viên mới

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu

duy199922

Thành viên mới

File đính kèm

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu

File đính kèm

duy199922

Thành viên mới

File đính kèm

Nhattanktnn

Thành viên gắn bó

Tình nghĩa giang hồ

Thanh sơn bất cải, lục thủy trường lưu

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng