Giúp em dùng hàm nhưng thay đổi dữ liệu ạ (1 người xem)

  • Thread starter Thread starter lala_qn
  • Ngày gửi Ngày gửi
Liên hệ QC

Người dùng đang xem chủ đề này

lala_qn

Thành viên tiêu biểu
Tham gia
2/5/09
Bài viết
598
Được thích
17
Nghề nghiệp
chưa ổn định
em chào anh chị !
em có up lại file vd3 (1) , vừa rùi 2 anh excel_lv1.5HieuCD đã giúp em viết code gần hoàn chỉnh file,
trong file hiện tại emcần kết quả ở sheet4, em có ghi yêu cầu ở sheet4 ạ
nhờ anh chị bổ sung dùm em code ở sheet4 để hoàn thiện file
em cảm ơn anh chị nhiều ạ !
 

File đính kèm

Lần chỉnh sửa cuối:
em chào anh chị !
em có file vd up kèm, trong file kết quả ở cột D,
em muốn kết quả vẫn giữ nguyên size và màu của dữ liệu
nhờ anh chị giúp dùm em hàm này với ạ.
cảm ơn anh chị nhiều !
Bạn chạy thử code này, hàm excel không làm được đâu bạn.
PHP:
Sub a()
Dim rng As Range, i As Long
Set rng = Range("a2:b" & [a100000].End(xlUp).Row)
For i = 1 To rng.Rows.Count
    rng(i, 1).Offset(, 2) = rng(i, 1) & ChrW(10) & rng(i, 2)
    rng(i, 1).Offset(, 2).Characters(1, Len(rng(i, 1))).Font.Color = rng(i, 1).Font.Color
    rng(i, 1).Offset(, 2).Characters(Len(rng(i, 1)) + 1, Len(rng(i, 2)) + 1).Font.Color = rng(i, 2).Font.Color
Next i
End Sub
 
Bạn chạy thử code này, hàm excel không làm được đâu bạn.
PHP:
Sub a()
Dim rng As Range, i As Long
Set rng = Range("a2:b" & [a100000].End(xlUp).Row)
For i = 1 To rng.Rows.Count
    rng(i, 1).Offset(, 2) = rng(i, 1) & ChrW(10) & rng(i, 2)
    rng(i, 1).Offset(, 2).Characters(1, Len(rng(i, 1))).Font.Color = rng(i, 1).Font.Color
    rng(i, 1).Offset(, 2).Characters(Len(rng(i, 1)) + 1, Len(rng(i, 2)) + 1).Font.Color = rng(i, 2).Font.Color
Next i
End Sub
dạ có thể dùng hàm dc ko anh, em ko rành dùng code ạ, thanks anh !
 

File đính kèm

Bạn bấm Alt+F11, vào Insert->module, rồi paste cái code trên vào, bấm F5 là được.
Hàm không làm được đâu bạn, bạn nhận file, bấm nút RUN!!!
dạ nếu vậy chắc phải dùng hàm rùi
em thấy màu thì thay đổi dc, nhưng size nó vẫn chưa thay đổi theo dữ liệu dc ạ
nhờ anh viết lại hàm dùm em theo vd2 em mới up lại ạ
cảm ơn anh !
 
dạ nếu vậy chắc phải dùng hàm rùi
em thấy màu thì thay đổi dc, nhưng size nó vẫn chưa thay đổi theo dữ liệu dc ạ
nhờ anh viết lại hàm dùm em theo vd2 em mới up lại ạ
cảm ơn anh !
Bạn sửa code lại như vầy:
PHP:
Sub Button1_Click()
Application.ScreenUpdating = False
Dim rng As Range, i As Long, j As Long, nlen As Long
Set rng = Range("a2:d" & [a100000].End(xlUp).Row)
[e2].Resize(rng.Rows.Count, 1).ClearContents
For i = 1 To rng.Rows.Count
    For j = 1 To rng.Columns.Count
        rng(i, 1).Offset(, 4) = rng(i, 1).Offset(, 4) & IIf(j = 1, "", ChrW(10)) & rng(i, j)
    Next j
    With rng(i, 1).Offset(, 4)
        nlen = 0
        For j = 1 To rng.Columns.Count
            nlen = nlen + Len(rng(i, j)) + 1
            .Characters(nlen - Len(rng(i, j)), nlen).Font.Color = rng(i, j).Font.Color
            .Characters(nlen - Len(rng(i, j)), nlen).Font.Size = rng(i, j).Font.Size
            .Characters(nlen - Len(rng(i, j)), nlen).Font.Bold = rng(i, j).Font.Bold
            .Characters(nlen - Len(rng(i, j)), nlen).Font.Italic = rng(i, j).Font.Italic
        Next j
    End With
Next i
Application.ScreenUpdating = True
End Sub
 

File đính kèm

Bạn sửa code lại như vầy:
PHP:
Sub Button1_Click()
Application.ScreenUpdating = False
Dim rng As Range, i As Long, j As Long, nlen As Long
Set rng = Range("a2:d" & [a100000].End(xlUp).Row)
[e2].Resize(rng.Rows.Count, 1).ClearContents
For i = 1 To rng.Rows.Count
    For j = 1 To rng.Columns.Count
        rng(i, 1).Offset(, 4) = rng(i, 1).Offset(, 4) & IIf(j = 1, "", ChrW(10)) & rng(i, j)
    Next j
    With rng(i, 1).Offset(, 4)
        nlen = 0
        For j = 1 To rng.Columns.Count
            nlen = nlen + Len(rng(i, j)) + 1
            .Characters(nlen - Len(rng(i, j)), nlen).Font.Color = rng(i, j).Font.Color
            .Characters(nlen - Len(rng(i, j)), nlen).Font.Size = rng(i, j).Font.Size
            .Characters(nlen - Len(rng(i, j)), nlen).Font.Bold = rng(i, j).Font.Bold
            .Characters(nlen - Len(rng(i, j)), nlen).Font.Italic = rng(i, j).Font.Italic
        Next j
    End With
Next i
Application.ScreenUpdating = True
End Sub
dạ anh chỉnh lại dùm em cột C khoảng cách nối với D
anh nhé !
 
ở sheet2 anh bỏ dùm e dấu gạch nối "-" thay vao đó là khoảng cách dùm em với ạ
em cảm ơn anh !
 
Bạn tìm đến dòng:
Case "Sheet2"
rng(i, 1).Offset(, 4) = rng(i, 1).Offset(, 4) & IIf(j = 1, "", IIf(j = 3, ChrW(10), "-")) & rng(i, j)

Và thay "-" bằng " "
 
Bạn tìm đến dòng:
Case "Sheet2"
rng(i, 1).Offset(, 4) = rng(i, 1).Offset(, 4) & IIf(j = 1, "", IIf(j = 3, ChrW(10), "-")) & rng(i, j)

Và thay "-" bằng " "
ở sheet2 nếu sửa như vậy thì trong code sẽ là: A khoảng cách nối B, xuống dòng C khoảng cách nối D
mà em cần là: A nối B, xuống dòng C khoảng cách nối D
nhờ anh chỉnh chổ này giúp em ạ !
 
excel_lv1.5 anh ơi , em ko biết gì về code mong anh giúp hộ e chổ này với ạ, cảm ơn anh !
 
nhờ anh chị xem và chỉnh dùm em code ở sheet2 với sheet4 giúp em với ạ
cảm ơn anh chị nhiều ạ !
 
nhờ anh chị xem và chỉnh dùm em code ở sheet2 với sheet4 giúp em với ạ
cảm ơn anh chị nhiều ạ !
Chạy thử code
Mã:
Sub Strformats(ByVal shName As String)
  Dim Rng As Range, tStr As String
  Dim i As Long, j As Long, sCol As Long, nlen As Long
  With Sheets(shName)
    sCol = .Range("A1").End(xlToRight).Column
    Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
    For i = 1 To Rng.Rows.Count
      tStr = Rng(i, 1).Value
      For j = 2 To sCol - 1
        Select Case shName
          Case "Sheet1"
            tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
          Case "Sheet2"
            tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
          Case "Sheet3"
            tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
        End Select
      Next j
    
      With Rng(i, sCol)
        .Value = tStr
        nlen = 0
        For j = 1 To sCol - 1
          nlen = nlen + Len(Rng(i, j)) + IIf(shName = "Sheet2" And j = 2, 0, 1)
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
        Next j
      End With
    Next i
  End With
End Sub
Sub Button2_Click()
  Dim i As Long, shArr()
  shArr = Array("Sheet1", "Sheet2", "Sheet3")
  Application.ScreenUpdating = False
  For i = 0 To UBound(shArr)
    Call Strformats(shArr(i))
  Next
  Application.ScreenUpdating = True
End Sub
Mới chỉnh lại code
 

File đính kèm

Lần chỉnh sửa cuối:
Chạy thử code
Mã:
Sub Strformats(ByVal shName As String)
  Dim Rng As Range, tStr As String
  Dim i As Long, j As Long, sCol As Long, nlen As Long
  With Sheets(shName)
    sCol = .Range("A1").End(xlToRight).Column
    Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
    For i = 1 To Rng.Rows.Count
      tStr = Rng(i, 1).Value
      For j = 2 To sCol - 1
        Select Case shName
          Case "Sheet1"
            tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
          Case "Sheet2"
            tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
          Case "Sheet3"
            tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
        End Select
      Next j
   
      With Rng(i, sCol)
        .Value = tStr
        nlen = 0
        For j = 1 To sCol - 1
          nlen = nlen + Len(Rng(i, j)) + IIf(shName = "Sheet2" And j = 2, 0, 1)
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
        Next j
      End With
    Next i
  End With
End Sub
Sub Button2_Click()
  Dim i As Long, shArr()
  shArr = Array("Sheet1", "Sheet2", "Sheet3")
  Application.ScreenUpdating = False
  For i = 0 To UBound(shArr)
    Call Strformats(shArr(i))
  Next
  Application.ScreenUpdating = True
End Sub
Mới chỉnh lại code
em pase code vào ko biết sai gì mà code ko chạy
anh xem giúp em với ạ
 

File đính kèm

dạ sheet2 ok rùi a
nhờ anh thêm code ở sheet4 với ạ
sheet4 em cần kết quả ở cột C: thay đổi dc, font chữ, màu chữ, size chữ, kiểu chữ
và: A nối với C
cảm ơn anh!
 
trong file vd3 em up lên, anh @excel_lv1.5 có viết giúp em hoàn chỉnh code ở sheet1 và sheet3
còn sheet2 và sheet4chưa đc hoàn chỉnh lắm, em có ghi nội dung cần ở trong mỗi sheet ạ
cảm ơn anh !
Sheet4 không có gì để xử lý
Mình dựa vào code của @excel_lv1.5 để viết lại theo cách của mình, cần gì cứ nói yêu cầu
 
Sheet4 không có gì để xử lý
Mình dựa vào code của @excel_lv1.5 để viết lại theo cách của mình, cần gì cứ nói yêu cầu
dạ anh dựa vào code anh @excel_lv1.5 viết thêm code ở sheet4 nội dung như sau ạ
sheet4 em cần kết quả ở cột C: thay đổi dc, font chữ, màu chữ, size chữ, kiểu chữ
và: A nối với B
cảm ơn anh!
 
trong bài em có up lại file thành vd3 (1), nhờ anh xem bài và viết thêm hộ em code ở sheet4 với ạ
em cảm ơn anh!
Mã:
Sub Strformats(ByVal shName As String)
  Dim Rng As Range, tStr As String
  Dim i As Long, j As Long, sCol As Long, nlen As Long
  With Sheets(shName)
    sCol = .Range("A1").End(xlToRight).Column
    Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
    For i = 1 To Rng.Rows.Count
      tStr = Rng(i, 1).Value
      For j = 2 To sCol - 1
        Select Case shName
          Case "Sheet1"
            tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
          Case "Sheet2"
            tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
          Case "Sheet3"
            tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
          Case Else
            tStr = tStr & Rng(i, j)
        End Select
      Next j
     
      With Rng(i, sCol)
        .Value = tStr
        nlen = 0
        For j = 1 To sCol - 1
          nlen = nlen + Len(Rng(i, j)) + IIf((shName = "Sheet2" Or shName = "Sheet4") And j = 2, 0, 1)
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
        Next j
      End With
    Next i
  End With
End Sub
Sub Button2_Click()
  Dim i As Long, shArr()
  shArr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
  Application.ScreenUpdating = False
  For i = 0 To UBound(shArr)
    Call Strformats(shArr(i))
  Next
  Application.ScreenUpdating = True
End Sub
 
Mã:
Sub Strformats(ByVal shName As String)
  Dim Rng As Range, tStr As String
  Dim i As Long, j As Long, sCol As Long, nlen As Long
  With Sheets(shName)
    sCol = .Range("A1").End(xlToRight).Column
    Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
    For i = 1 To Rng.Rows.Count
      tStr = Rng(i, 1).Value
      For j = 2 To sCol - 1
        Select Case shName
          Case "Sheet1"
            tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
          Case "Sheet2"
            tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
          Case "Sheet3"
            tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
          Case Else
            tStr = tStr & Rng(i, j)
        End Select
      Next j
   
      With Rng(i, sCol)
        .Value = tStr
        nlen = 0
        For j = 1 To sCol - 1
          nlen = nlen + Len(Rng(i, j)) + IIf((shName = "Sheet2" Or shName = "Sheet4") And j = 2, 0, 1)
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
        Next j
      End With
    Next i
  End With
End Sub
Sub Button2_Click()
  Dim i As Long, shArr()
  shArr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4")
  Application.ScreenUpdating = False
  For i = 0 To UBound(shArr)
    Call Strformats(shArr(i))
  Next
  Application.ScreenUpdating = True
End Sub
em chạy thì thấy ra kết quả ok hết rùi anh
em thấy còn lỗi chổ này nữa anh
vd sheet1 nhập dữ liệu xong bấm Run để chạy ra dc kết quả, sau đó em xóa dữ liệu đi bấm Run thì nó vẫn hiển thị kết quả cũ anh
em thấy 4 sheet đều bị như vậy anh
 
Lần chỉnh sửa cuối:
em chạy thì thấy ra kết quả ok hết rùi anh
em thấy còn lỗi chổ này nữa anh
vd sheet1 nhập dữ liệu xong bấm Run để chạy ra dc kết quả, sau đó em xóa dữ liệu đi bấm Run thì nó vẫn hiển thị kết quả cũ anh
em thấy 4 sheet đều bị như vậy anh
Thêm 4 dòng lệnh
i = .Cells(65500, sCol).End(xlUp).Row
If i > 1 Then .Range("E2:E" & i).ClearContents
i = .Range("A65500").End(xlUp).Row

If i < 2 Then Exit Sub
Mã:
Sub Strformats(ByVal shName As String)
  Dim Rng As Range, tStr As String
  Dim i As Long, j As Long, sCol As Long, nlen As Long
  With Sheets(shName)
    sCol = .Range("A1").End(xlToRight).Column
    i = .Cells(65500, sCol).End(xlUp).Row
    If i > 1 Then .Range("E2:E" & i).ClearContents
    i = .Range("A65500").End(xlUp).Row
    If i < 2 Then Exit Sub
    Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
    For i = 1 To Rng.Rows.Count
      tStr = Rng(i, 1).Value
      For j = 2 To sCol - 1
        Select Case shName
          Case "Sheet1"
            tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
          Case "Sheet2"
            tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
          Case "Sheet3"
            tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
          Case Else
            tStr = tStr & Rng(i, j)
        End Select
      Next j
     
      With Rng(i, sCol)
        .Value = tStr
        nlen = 0
        For j = 1 To sCol - 1
          nlen = nlen + Len(Rng(i, j)) + IIf((shName = "Sheet2" Or shName = "Sheet4") And j = 2, 0, 1)
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
        Next j
      End With
    Next i
  End With
End Sub
 
Thêm 4 dòng lệnh
i = .Cells(65500, sCol).End(xlUp).Row
If i > 1 Then .Range("E2:E" & i).ClearContents
i = .Range("A65500").End(xlUp).Row

If i < 2 Then Exit Sub
Mã:
Sub Strformats(ByVal shName As String)
  Dim Rng As Range, tStr As String
  Dim i As Long, j As Long, sCol As Long, nlen As Long
  With Sheets(shName)
    sCol = .Range("A1").End(xlToRight).Column
    i = .Cells(65500, sCol).End(xlUp).Row
    If i > 1 Then .Range("E2:E" & i).ClearContents
    i = .Range("A65500").End(xlUp).Row
    If i < 2 Then Exit Sub
    Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
    For i = 1 To Rng.Rows.Count
      tStr = Rng(i, 1).Value
      For j = 2 To sCol - 1
        Select Case shName
          Case "Sheet1"
            tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
          Case "Sheet2"
            tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
          Case "Sheet3"
            tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
          Case Else
            tStr = tStr & Rng(i, j)
        End Select
      Next j
    
      With Rng(i, sCol)
        .Value = tStr
        nlen = 0
        For j = 1 To sCol - 1
          nlen = nlen + Len(Rng(i, j)) + IIf((shName = "Sheet2" Or shName = "Sheet4") And j = 2, 0, 1)
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
        Next j
      End With
    Next i
  End With
End Sub
bị lỗi ko chạy dc anh ạ .
 
Anh để em. :p:p
----------------------
bị lỗi ko chạy dc anh ạ .
Mình bị lỗi lầm làm sao? Chụp cái hình lỗi, chép nội dung lỗi, lỗi tại dòng nào? Đã làm gì mà kêu lỗi?

Mình viết thì sao cho có đầu có cuối, viết cho rõ ràng, không viết tắt, viết cho đúng chính tả nha.!!!
 
anh ơi ! giúp dùm em thêm 1 sheet5 nữa với ạ,
cũng nội dung đó, A nối với B nối với C
em cảm ơn anh ạ !
 

File đính kèm

dạ em mới sữa bài up lại file vd3 (2).xlsb có thêm sheet5 vào rùi anh
nhờ anh xem giúp e

dạ file em up kèm ở đây anh nhé
cảm ơn anh nhiều ạ !
Mã:
Sub Strformats(ByVal shName As String)
  Dim Rng As Range, tStr As String
  Dim i As Long, j As Long, sCol As Long, nlen As Long
  With Sheets(shName)
    sCol = .Range("A1").End(xlToRight).Column
    i = .Range("A65500").End(xlUp).Row
    If i < 2 Then Exit Sub
    Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
    For i = 1 To Rng.Rows.Count
      tStr = Rng(i, 1).Value
      For j = 2 To sCol - 1
        Select Case shName
          Case "Sheet1"
            tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
          Case "Sheet2"
            tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
          Case "Sheet3"
            tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
          Case Else
            tStr = tStr & Rng(i, j)
        End Select
      Next j
    
      With Rng(i, sCol)
        .Value = tStr
        nlen = 0
        For j = 1 To sCol - 1
          nlen = nlen + Len(Rng(i, j)) + IIf((shName = "Sheet2" And j = 2) Or ((shName = "Sheet4" Or shName = "Sheet5") And j > 1), 0, 1)
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
        Next j
      End With
    Next i
  End With
End Sub
Sub Button2_Click()
  Dim i As Long, shArr()
  shArr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
  Application.ScreenUpdating = False
  For i = 0 To UBound(shArr)
    Call Strformats(shArr(i))
  Next
  Application.ScreenUpdating = True
End Sub
 
Mã:
Sub Strformats(ByVal shName As String)
  Dim Rng As Range, tStr As String
  Dim i As Long, j As Long, sCol As Long, nlen As Long
  With Sheets(shName)
    sCol = .Range("A1").End(xlToRight).Column
    i = .Range("A65500").End(xlUp).Row
    If i < 2 Then Exit Sub
    Set Rng = .Range("A2:A" & .Range("A65500").End(xlUp).Row)
    For i = 1 To Rng.Rows.Count
      tStr = Rng(i, 1).Value
      For j = 2 To sCol - 1
        Select Case shName
          Case "Sheet1"
            tStr = tStr & IIf(j = 4, " ", ChrW(10)) & Rng(i, j)
          Case "Sheet2"
            tStr = tStr & IIf(j = 2, "", IIf(j = 3, ChrW(10), " ")) & Rng(i, j)
          Case "Sheet3"
            tStr = tStr & IIf(j = 2, ChrW(10), " ") & Rng(i, j)
          Case Else
            tStr = tStr & Rng(i, j)
        End Select
      Next j
   
      With Rng(i, sCol)
        .Value = tStr
        nlen = 0
        For j = 1 To sCol - 1
          nlen = nlen + Len(Rng(i, j)) + IIf((shName = "Sheet2" And j = 2) Or ((shName = "Sheet4" Or shName = "Sheet5") And j > 1), 0, 1)
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Color = Rng(i, j).Font.Color
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Size = Rng(i, j).Font.Size
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Bold = Rng(i, j).Font.Bold
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Italic = Rng(i, j).Font.Italic
          .Characters(nlen - Len(Rng(i, j)), nlen).Font.Name = Rng(i, j).Font.Name
        Next j
      End With
    Next i
  End With
End Sub
Sub Button2_Click()
  Dim i As Long, shArr()
  shArr = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4", "Sheet5")
  Application.ScreenUpdating = False
  For i = 0 To UBound(shArr)
    Call Strformats(shArr(i))
  Next
  Application.ScreenUpdating = True
End Sub
em chạy thử thì thấy là A nối B, kết quả ở C
trong file vd4 em cần: A nối B nối C, kết quả ở C ạ
anh sửa code lại dùm em với ạ
cảm ơn anh nhiều !
 

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

Back
Top Bottom