Xin giúp đỡ về tách kí tự và xóa chuỗi trong cột

ductoan5454 · 27/9/17

Mình có 1 file Excel 9k dòng nhưng post kiểu lên nhờ ae giải giúp và cho mình hàm để tách
Vì lí do công việc nên k tiện post file đó lên.

PacificPR · 27/9/17

ductoan5454 đã viết:
Mình có 1 file Excel 9k dòng nhưng post kiểu lên nhờ ae giải giúp và cho mình hàm để tách
Vì lí do công việc nên k tiện post file đó lên.

Vậy trong chữ có số thì có xóa luôn không bạn. Thôi tạm vậy đi

PHP:

Sub Cauhoi1()
    Dim sArr, dArr, I As Long
With Sheet1
    sArr = .Range("A2", .Range("A" & Rows.Count).End(3)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 1)
    For I = 1 To UBound(sArr)
        If IsNumeric(sArr(I, 1)) Then dArr(I, 1) = sArr(I, 1)
    Next I
    .Range("B2").Resize(I - 1, 1) = dArr
End With
End Sub

PHP:

Sub Cauhoi2()
    Dim sArr, dArr, I As Long, J As Long, Str As String
    With Sheet1
        sArr = .Range("I2", .Range("I" & Rows.Count).End(3)).Value
        ReDim dArr(1 To UBound(sArr), 1 To 1)
        For I = 1 To UBound(sArr)
            If IsNumeric(Mid(sArr(I, 1), 1, 1)) Then
                Str = ""
                For J = 1 To Len(sArr(I, 1))
                    Select Case Asc(Mid(sArr(I, 1), J, 1))
                        Case 40 To 57, 94
                            Str = Str & Mid(sArr(I, 1), J, 1)
                        Case Else
                            Exit For
                    End Select
                Next J
                dArr(I, 1) = Str
            Else
                dArr(I, 1) = sArr(I, 1)
            End If
        Next I
        .Range("J2").Resize(I - 1, 1) = dArr
    End With
End Sub

ndu96081631 · 27/9/17

PacificPR đã viết:

Vậy trong chữ có số thì có xóa luôn không bạn. Thôi tạm vậy đi

PHP:

Sub Cauhoi1()
    Dim sArr, dArr, I As Long
With Sheet1
    sArr = .Range("A2", .Range("A" & Rows.Count).End(3)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 1)
    For I = 1 To UBound(sArr)
        If IsNumeric(sArr(I, 1)) Then dArr(I, 1) = sArr(I, 1)
    Next I
    .Range("B2").Resize(I - 1, 1) = dArr
End With
End Sub

PHP:

Sub Cauhoi2()
    Dim sArr, dArr, I As Long, J As Long, Str As String
    With Sheet1
        sArr = .Range("I2", .Range("I" & Rows.Count).End(3)).Value
        ReDim dArr(1 To UBound(sArr), 1 To 1)
        For I = 1 To UBound(sArr)
            If IsNumeric(Mid(sArr(I, 1), 1, 1)) Then
                Str = ""
                For J = 1 To Len(sArr(I, 1))
                    Select Case Asc(Mid(sArr(I, 1), J, 1))
                        Case 40 To 57, 94
                            Str = Str & Mid(sArr(I, 1), J, 1)
                        Case Else
                            Exit For
                    End Select
                Next J
                dArr(I, 1) = Str
            Else
                dArr(I, 1) = sArr(I, 1)
            End If
        Next I
        .Range("J2").Resize(I - 1, 1) = dArr
    End With
End Sub

Câu 1 có thể làm theo kiểu này:
- Copy cột A paste sang cột B
- Tại cột B, bấm Ctrl + G\Special\Constants\Text rồi Delete

Mã:

Sub CauI()
  On Error Resume Next
  Range("B2:B1000").Value = Range("A2:A1000").Value
  Range("B2:B1000").SpecialCells(xlCellTypeConstants, 2).Clear
End Sub

ductoan5454 · 28/9/17

ndu96081631 đã viết:
Câu 1 có thể làm theo kiểu này:
- Copy cột A paste sang cột B
- Tại cột B, bấm Ctrl + G\Special\Constants\Text rồi Delete

Mã:

Sub CauI() On Error Resume Next Range("B2:B1000").Value = Range("A2:A1000").Value Range("B2:B1000").SpecialCells(xlCellTypeConstants, 2).Clear End Sub

Tks bạn nhé. Câu 1 làm nvay rất nhanh. Mình đang đau đầu câu 2. Bạn xem có cách nào giải giúp m với?

ductoan5454 · 28/9/17

PacificPR đã viết:

Vậy trong chữ có số thì có xóa luôn không bạn. Thôi tạm vậy đi

PHP:

Sub Cauhoi1()
    Dim sArr, dArr, I As Long
With Sheet1
    sArr = .Range("A2", .Range("A" & Rows.Count).End(3)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 1)
    For I = 1 To UBound(sArr)
        If IsNumeric(sArr(I, 1)) Then dArr(I, 1) = sArr(I, 1)
    Next I
    .Range("B2").Resize(I - 1, 1) = dArr
End With
End Sub

PHP:

Sub Cauhoi2()
    Dim sArr, dArr, I As Long, J As Long, Str As String
    With Sheet1
        sArr = .Range("I2", .Range("I" & Rows.Count).End(3)).Value
        ReDim dArr(1 To UBound(sArr), 1 To 1)
        For I = 1 To UBound(sArr)
            If IsNumeric(Mid(sArr(I, 1), 1, 1)) Then
                Str = ""
                For J = 1 To Len(sArr(I, 1))
                    Select Case Asc(Mid(sArr(I, 1), J, 1))
                        Case 40 To 57, 94
                            Str = Str & Mid(sArr(I, 1), J, 1)
                        Case Else
                            Exit For
                    End Select
                Next J
                dArr(I, 1) = Str
            Else
                dArr(I, 1) = sArr(I, 1)
            End If
        Next I
        .Range("J2").Resize(I - 1, 1) = dArr
    End With
End Sub

Đúng yêu cầu của mình luôn.TKS BẠN. TRIỆU LIKE

ductoan5454 · 28/9/17

PacificPR đã viết:

Vậy trong chữ có số thì có xóa luôn không bạn. Thôi tạm vậy đi

PHP:

Sub Cauhoi1()
    Dim sArr, dArr, I As Long
With Sheet1
    sArr = .Range("A2", .Range("A" & Rows.Count).End(3)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 1)
    For I = 1 To UBound(sArr)
        If IsNumeric(sArr(I, 1)) Then dArr(I, 1) = sArr(I, 1)
    Next I
    .Range("B2").Resize(I - 1, 1) = dArr
End With
End Sub

PHP:

Sub Cauhoi2()
    Dim sArr, dArr, I As Long, J As Long, Str As String
    With Sheet1
        sArr = .Range("I2", .Range("I" & Rows.Count).End(3)).Value
        ReDim dArr(1 To UBound(sArr), 1 To 1)
        For I = 1 To UBound(sArr)
            If IsNumeric(Mid(sArr(I, 1), 1, 1)) Then
                Str = ""
                For J = 1 To Len(sArr(I, 1))
                    Select Case Asc(Mid(sArr(I, 1), J, 1))
                        Case 40 To 57, 94
                            Str = Str & Mid(sArr(I, 1), J, 1)
                        Case Else
                            Exit For
                    End Select
                Next J
                dArr(I, 1) = Str
            Else
                dArr(I, 1) = sArr(I, 1)
            End If
        Next I
        .Range("J2").Resize(I - 1, 1) = dArr
    End With
End Sub

Bạn pro có thể giúp mình Help2 này với

PacificPR · 28/9/17

ductoan5454 đã viết:
Bạn pro có thể giúp mình Help2 này với

Bạn thử cái này xem nha

PHP:

Sub Cauhoi2a()
    Dim sArr, dArr, I As Long, J As Long, Str1 As String, Str2 As String
With Sheet1
    sArr = .Range("A1", .Range("A" & Rows.Count).End(3)).Value
    ReDim dArr(1 To UBound(sArr), 1 To 2)
    For I = 1 To UBound(sArr)
        If IsNumeric(Mid(sArr(I, 1), 1, 1)) Then
            Str1 = "": Str2 = ""
            For J = 1 To Len(sArr(I, 1))
                Select Case Asc(Mid(sArr(I, 1), J, 1))
                    Case 40 To 57, 94
                        Str1 = Str1 & Mid(sArr(I, 1), J, 1)
                    Case Else
                        Str2 = Mid(sArr(I, 1), J , Len(sArr(I, 1)))
                        Exit For
                End Select
            Next J
            dArr(I, 1) = Str1: dArr(I, 2) = Str2
        Else
            dArr(I, 2) = sArr(I, 1)
        End If
    Next I
    .Range("B1").Resize(I - 1, 2) = dArr
End With
End Sub

P/s Xin phép chủ Topic cho mình tô trắng 2 từ trong bài tríc dẫn nha. Vì vì không thích 2 từ đó

ndu96081631 · 28/9/17

ductoan5454 đã viết:
Bạn pro có thể giúp mình Help2 này với

Có cách "tà đạo" này:

Mã:

Sub Test()
  Dim arr, sTmp
  Dim lR As Long, dTmp As Double
  arr = Range("A1:A1000").Value
  ReDim aRes(1 To UBound(arr), 1 To 2)
  For lR = 1 To UBound(arr)
    If Not IsEmpty(arr(lR, 1)) Then
      sTmp = arr(lR, 1)
      dTmp = Val(sTmp)
      If dTmp = 0 Then
        aRes(lR, 2) = sTmp
      Else
        aRes(lR, 2) = Mid(sTmp, InStr(1, sTmp, dTmp) + Len(CStr(dTmp)))
        aRes(lR, 1) = "'" & Left(sTmp, Len(sTmp) - Len(aRes(lR, 2)))
      End If
    End If
  Next
  Range("B1:C1000").Value = aRes
End Sub

Yêu cầu là: dữ liệu không có dạng 00.1230abc <--- Tức không có con zero ở cuối số

PacificPR · 28/9/17

ndu96081631 đã viết:

Có cách "tà đạo" này:

Mã:

Sub Test()
  Dim arr, sTmp
  Dim lR As Long, dTmp As Double
  arr = Range("A1:A1000").Value
  ReDim aRes(1 To UBound(arr), 1 To 2)
  For lR = 1 To UBound(arr)
    If Not IsEmpty(arr(lR, 1)) Then
      sTmp = arr(lR, 1)
      dTmp = Val(sTmp)
      If dTmp = 0 Then
        aRes(lR, 2) = sTmp
      Else
        aRes(lR, 2) = Mid(sTmp, InStr(1, sTmp, dTmp) + Len(CStr(dTmp)))
        aRes(lR, 1) = "'" & Left(sTmp, Len(sTmp) - Len(aRes(lR, 2)))
      End If
    End If
  Next
  Range("B1:C1000").Value = aRes
End Sub

Yêu cầu là: dữ liệu không có dạng 00.1230abc <--- Tức không có con zero ở cuối số

Hình như chưa đúng Thầy ạ. Nếu dãy có dang 123abc thì tách được '123 và abc. Còn dạng 0.14hdge thì tách ra '0. và 14hdge. Hay máy em định dạng ngăn cách số lẻ là dấu ","

ndu96081631 · 28/9/17

PacificPR đã viết:
Hình như chưa đúng Thầy ạ. Nếu dãy có dang 123abc thì tách được '123 và abc. Còn dạng 0.14hdge thì tách ra '0. và 14hdge. Hay máy em định dạng ngăn cách số lẻ là dấu ","

Chắc là vậy!
Ở trên tôi đã nói là "tà đạo" rồi (vì dùng hàm Val) nên sẽ có lúc sai sót

CarotNho · 28/9/17

ductoan5454 đã viết:
Bạn pro có thể giúp mình Help2 này với

bạn thử cách trong file đính kèm nhóe

ductoan5454 · 28/9/17

Cảm ơn cả nhà mình nhiều nha. Mình đã làm được rồi.

ductoan5454 · 28/9/17

CarotNho đã viết:
bạn thử cách trong file đính kèm nhóe

Cách này hay mà đơn giản

Xin giúp đỡ về tách kí tự và xóa chuỗi trong cột

ductoan5454

Thành viên mới

File đính kèm

PacificPR

Thành viên mới

File đính kèm

ndu96081631

Huyền thoại GPE

ductoan5454

Thành viên mới

ductoan5454

Thành viên mới

ductoan5454

Thành viên mới

File đính kèm

PacificPR

Thành viên mới

ndu96081631

Huyền thoại GPE

PacificPR

Thành viên mới

ndu96081631

Huyền thoại GPE

CarotNho

Thành viên chính thức

File đính kèm

ductoan5454

Thành viên mới

ductoan5454

Thành viên mới

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