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

Liên hệ QC
ductoan5454

ductoan5454

Thành viên mới
Tham gia
8/7/14
Bài viết
13
Được thích
1
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.
 

File đính kèm

  • Help.xlsx
    9.9 KB · Đọc: 14
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.
Nhấp chuột vào đây để mở rộng...
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
 

File đính kèm

  • Tach.xlsm
    18.1 KB · Đọc: 7
Lần chỉnh sửa cuối:
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
Nhấp chuột vào đây để mở rộng...
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
 
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
Nhấp chuột vào đây để mở rộng...
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?
 
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
Nhấp chuột vào đây để mở rộng...
Đúng yêu cầu của mình luôn.TKS BẠN. TRIỆU LIKE
 
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
Nhấp chuột vào đây để mở rộng...
Bạn pro có thể giúp mình Help2 này với
 

File đính kèm

  • Help2.xlsx
    9.4 KB · Đọc: 10
ductoan5454 đã viết:
Bạn pro có thể giúp mình Help2 này với
Nhấp chuột vào đây để mở rộng...
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ừ đó :confused:
 
Lần chỉnh sửa cuối:
ductoan5454 đã viết:
Bạn pro có thể giúp mình Help2 này với
Nhấp chuột vào đây để mở rộng...
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ố
 
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ố
Nhấp chuột vào đây để mở rộng...
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 ","
 
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 ","
Nhấp chuột vào đây để mở rộng...
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
 
Cảm ơn cả nhà mình nhiều nha. Mình đã làm được rồi.
:D :D :D
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

ann266
Kế toán kho F&B
    • Cười
Trả lời
13
Đọc
131
le_vis
L
T
Tổng hợp từ Sheet1 qua Sheet2
Trả lời
5
Đọc
74
senna
senna
doandat92
Tách chữ in đậm
Trả lời
7
Đọc
53
Hoàng Tuấn 868
H
senna
  • Question
Xin giúp đỡ tổng hợp dữ liệu từ nhiều file vào 1 file mà không cần mở file
Trả lời
0
Đọc
32
senna
senna
V
  • Question
GIúp code xóa các tên mặt hàng trùng nhau, chỉ chừa lại tên cho dòng trên cùng
Trả lời
10
Đọc
300
Phan Thế Hiệp
Phan Thế Hiệp
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

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

Back
Top Bottom