Tách nội dung được tô màu

[Minh Ngọc LH]

Chào cả nhà

Em muốn tách số được tô màu sang cột kế bên như trong file
Cả nhà giúp em với, em cảm ơn!

 

[HieuCD]

Chào cả nhà

Em muốn tách số được tô màu sang cột kế bên như trong file
Cả nhà giúp em với, em cảm ơn!

Chạy code

Sub ABC()
  Dim eR&, fj&, ln&, i&, j&, txt$, res()
  With Sheets("Sheet1")
    eR = .Range("C1000000").End(xlUp).Row
    ReDim res(6 To eR, 1 To 1)
    For i = 6 To eR
      fj = 0
      txt = .Range("C" & i).Value
      ln = Len(txt)
      For j = 1 To ln
        If .Range("C" & i).Characters(j, 1).Font.ColorIndex = 18 Then
          If fj = 0 And IsNumeric(Mid(txt, j, 1)) Then fj = j
        ElseIf fj <> 0 Then
          res(i, 1) = Mid(txt, fj, j - fj)
          Exit For
        End If
      Next j
    Next i
    .Range("D6:D" & eR) = res
  End With
End Sub

 

[BuiQuangThuan]

Em muốn tách số được tô màu sang cột kế bên như trong file
Cả nhà giúp em với, em cảm ơn!

Thử hàm này coi sao?

Function Tachchuoi(Rng As Range)
    Dim i&, Tmp
    For i = 1 To Len(Rng)
        If Rng.Characters(i, 1).Font.ColorIndex = 18 Then
            If IsNumeric(Mid(Rng.Value, i, 1)) = True Then
                Tmp = Tmp & Mid(Rng.Value, i, 1)
            End If
        End If
    Next
    Tachchuoi = CLng(Tmp)
End Function

D6= Tachchuoi(C6)

 

[Minh Ngọc LH]

Chạy code

Sub ABC()
  Dim eR&, fj&, ln&, i&, j&, txt$, res()
  With Sheets("Sheet1")
    eR = .Range("C1000000").End(xlUp).Row
    ReDim res(6 To eR, 1 To 1)
    For i = 6 To eR
      fj = 0
      txt = .Range("C" & i).Value
      ln = Len(txt)
      For j = 1 To ln
        If .Range("C" & i).Characters(j, 1).Font.ColorIndex = 18 Then
          If fj = 0 And IsNumeric(Mid(txt, j, 1)) Then fj = j
        ElseIf fj <> 0 Then
          res(i, 1) = Mid(txt, fj, j - fj)
          Exit For
        End If
      Next j
    Next i
    .Range("D6:D" & eR) = res
  End With
End Sub

Cảm ơn anh, code rất ổn ạ

Bài đã được tự động gộp: 2/8/22

Thử hàm này coi sao?

Function Tachchuoi(Rng As Range)
    Dim i&, Tmp
    For i = 1 To Len(Rng)
        If Rng.Characters(i, 1).Font.ColorIndex = 18 Then
            If IsNumeric(Mid(Rng.Value, i, 1)) = True Then
                Tmp = Tmp & Mid(Rng.Value, i, 1)
            End If
        End If
    Next
    Tachchuoi = CLng(Tmp)
End Function

D6= Tachchuoi(C6)

cảm ơn anh!

 

[Minh Ngọc LH]

Chạy code

Sub ABC()
  Dim eR&, fj&, ln&, i&, j&, txt$, res()
  With Sheets("Sheet1")
    eR = .Range("C1000000").End(xlUp).Row
    ReDim res(6 To eR, 1 To 1)
    For i = 6 To eR
      fj = 0
      txt = .Range("C" & i).Value
      ln = Len(txt)
      For j = 1 To ln
        If .Range("C" & i).Characters(j, 1).Font.ColorIndex = 18 Then
          If fj = 0 And IsNumeric(Mid(txt, j, 1)) Then fj = j
        ElseIf fj <> 0 Then
          res(i, 1) = Mid(txt, fj, j - fj)
          Exit For
        End If
      Next j
    Next i
    .Range("D6:D" & eR) = res
  End With
End Sub

anh cho em hỏi chút xíu, hình như đưa dữ liệu vào mảng bị mất màu thì phải ( ví dụ: arr = .range("C6:C" & lr).value). vì khi cắt từng chữ ra để kiểm tra màu thì không có chữ nào có mã màu 18 hết

 

[Nhattanktnn]

anh cho em hỏi chút xíu, hình như đưa dữ liệu vào mảng bị mất màu thì phải ( ví dụ: arr = .range("C6:C" & lr).value). vì khi cắt từng chữ ra để kiểm tra màu thì không có chữ nào có mã màu 18 hết

Mảng chỉ lưu giá trị thôi, bạn xem kỹ, khi bác ấy duyệt dữ liệu thì xét:

If .Range("C" & i).Characters(j, 1).Font.ColorIndex = 18 Then

Vẫn xét trong Range trên sheet, chỉ là ghi dữ liệu sau khi tách được vào mảng thôi

 

[Minh Ngọc LH]

Mảng chỉ lưu giá trị thôi, bạn xem kỹ, khi bác ấy duyệt dữ liệu thì xét:

Vẫn xét trong Range trên sheet, chỉ là ghi dữ liệu sau khi tách được vào mảng thôi

Thảo nào em làm mà ko ra kết quả nên ...
Cảm ơn anh!

 

[HUONGHCKT]

Thử hàm này coi sao?

Quá hay.