Sửa giúp code xóa khoảng trắng trong excel (4 người xem)

[Nguyễn Hồng Quang]

Dear all

Từ yêu cầu thực tế của bên mình và Sau khi tìm hiểu trên diễn đàn về code xóa khoảng trắng trong excel
mình trích ra 1 code sau:

 Public Sub Xoakhoangtrong()
For rw = Cells(65536, 2).End(xlUp).Row To 2 Step -1
If Cells(rw, 2).Value <> blank Then Cells(rw, 2).Replace what:=" ", replacement:=""
Next rw
End Sub

Vấn đề là khi mình chạy code này thấy khá chậm (ví dụ như file mình gửi kèm).
Mình tha thiết Mong các cao thủ có thể cải thiện code để chạy mượt hơn

Mình rất hiểu là ở bảng tính này nếu dùng hàm substitute() của excel rồi copy paste thì tốc độ sẽ nhanh hơn,
nhưng do tính chất công việc của Cty mình có số lượng dòng dữ liệu lớn và các nhân viên đổ dữ liệu của Cty còn yếu kém về excel nên mình nghĩ việc tạo 1 button rồi gắn code vào sẽ giúp các nhân viên làm việc hiệu quả hơn, tránh nhầm lẫn, sai sót

 

[concogia]

Dear all

Từ yêu cầu thực tế của bên mình và Sau khi tìm hiểu trên diễn đàn về code xóa khoảng trắng trong excel
mình trích ra 1 code sau:

 Public Sub Xoakhoangtrong()
For rw = Cells(65536, 2).End(xlUp).Row To 2 Step -1
If Cells(rw, 2).Value <> blank Then Cells(rw, 2).Replace what:=" ", replacement:=""
Next rw
End Sub

Vấn đề là khi mình chạy code này thấy khá chậm (ví dụ như file mình gửi kèm).
Mình tha thiết Mong các cao thủ có thể cải thiện code để chạy mượt hơn

Mình rất hiểu là ở bảng tính này nếu dùng hàm substitute() của excel rồi copy paste thì tốc độ sẽ nhanh hơn,
nhưng do tính chất công việc của Cty mình có số lượng dòng dữ liệu lớn và các nhân viên đổ dữ liệu của Cty còn yếu kém về excel nên mình nghĩ việc tạo 1 button rồi gắn code vào sẽ giúp các nhân viên làm việc hiệu quả hơn, tránh nhầm lẫn, sai sót

Bạn dùng cách xóa trực tiếp trên sheet nên nó chạy hơi lâu, bạn thử dùng mảng cho bài này có thể sẽ cải thiện được tốc độ

Public Sub Xoa()
    Dim Vung, Kq() As String, I
    Vung = Range([B2], [B50000].End(xlUp))
    ReDim Kq(1 To UBound(Vung), 1 To 1)
        For I = 1 To UBound(Vung)
            Vung(I, 1) = CStr(Vung(I, 1))
            Kq(I, 1) = Replace(Vung(I, 1), " ", "")
        Next I
    [B2].Resize(UBound(Vung)) = Kq
End Sub

Thân

 

[Nguyễn Hồng Quang]

Code của bạn chạy nhanh và giúp cho cty của mình bớt tốn hạt dưa rất nhiều
Thay mặt anh em cty cảm ơn bạn concogia nhiều
Nhưng bạn sửa lại code 1 chút sao cho khi bảng dữ liệu chỉ có 1 dòng dữ liệu thì excle vẫn thực thi mà không báo lỗi Type mismatch
Bạn khắc phục giúp mình với, thank bạn trước

 

[befaint]

Code của bạn chạy nhanh và giúp cho cty của mình bớt tốn hạt dưa rất nhiều
Thay mặt anh em cty cảm ơn bạn concogia nhiều
Nhưng bạn sửa lại code 1 chút sao cho khi bảng dữ liệu chỉ có 1 dòng dữ liệu thì excle vẫn thực thi mà không báo lỗi Type mismatch
Bạn khắc phục giúp mình với, thank bạn trước

0 dòng dữ liệu cũng không thấy lỗi? Không biết bug lỗi (tô màu vàng) ở dòng nào?

Ngoài ra, bài này làm vầy cũng được.
- Đặt chuột tại cell [B2]
- Nhấn tổ hợp phím ctrl + shift + arrow down
- Nhấn ctrl + H.
Cửa sổ Find and Replace:
Find what: nhập vào 1 khoảng trắng (gõ phím spacebar 1 cái)
Mục Replace with: {Không nhập gì}
Click Replace All
OK
(mất khoảng 2 giây)

 

[concogia]

Code của bạn chạy nhanh và giúp cho cty của mình bớt tốn hạt dưa rất nhiều
Thay mặt anh em cty cảm ơn bạn concogia nhiều
Nhưng bạn sửa lại code 1 chút sao cho khi bảng dữ liệu chỉ có 1 dòng dữ liệu thì excle vẫn thực thi mà không báo lỗi Type mismatch
Bạn khắc phục giúp mình với, thank bạn trước

Khai báo lại vùng dữ liệu của code tý tẹo
Mà sao dữ liệu chỉ có 1 dòng nhỉ? Híc
Thân

Public Sub Xoa()
    Dim Vung, Kq() As String, I
    Vung = Range([B1], [B50000].End(xlUp))
    ReDim Kq(1 To UBound(Vung), 1 To 1)
    Kq(1, 1) = Vung(1, 1)
        For I = 2 To UBound(Vung)
            Vung(I, 1) = CStr(Vung(I, 1))
            Kq(I, 1) = Replace(Vung(I, 1), " ", "")
        Next I
    [B1].Resize(UBound(Vung)) = Kq
End Sub

 

[Ba Tê]

Khai báo lại vùng dữ liệu của code tý tẹo
Mà sao dữ liệu chỉ có 1 dòng nhỉ? Híc
Thân

Lỡ ... không có dòng dữ liệu nào mà lỡ ..."RUNG" thì sao?
Híc, híc, híc 3 cái.
Dzọt lẹ!!!!!!!!!!!!!!!!!!!!!

 

[Nguyễn Hồng Quang]

Khai báo lại vùng dữ liệu của code tý tẹo
Mà sao dữ liệu chỉ có 1 dòng nhỉ? Híc
Thân

Public Sub Xoa()
    Dim Vung, Kq() As String, I
    Vung = Range([B1], [B50000].End(xlUp))
    ReDim Kq(1 To UBound(Vung), 1 To 1)
    Kq(1, 1) = Vung(1, 1)
        For I = 2 To UBound(Vung)
            Vung(I, 1) = CStr(Vung(I, 1))
            Kq(I, 1) = Replace(Vung(I, 1), " ", "")
        Next I
    [B1].Resize(UBound(Vung)) = Kq
End Sub

Hết lỗi rồi Thank bạn nhiều
Bên mình thì đa số là mỗi lần đổ dữ liệu vào là trên 100 dòng. Nhưng thỉnh thoảng copy paste từ mail xuống cũng bị sót, nên phải đổ bổ sung 1, 2 dòng

 

[LienDong]

Các bạn cho mình hỏi, trong câu có những khoảng trắng thừa (thừa đầu hay ở giữa hoặc ở cuối câu), bây giờ muốn dùng code để xóa (thay thế hàm Trim) thì code phải viết như thế nào, mình muốn xóa các khoảng trắng thừa cho 1 sheet (nếu dùng công thức thừ rất lâu)

 

[ndu96081631]

Các bạn cho mình hỏi, trong câu có những khoảng trắng thừa (thừa đầu hay ở giữa hoặc ở cuối câu), bây giờ muốn dùng code để xóa (thay thế hàm Trim) thì code phải viết như thế nào, mình muốn xóa các khoảng trắng thừa cho 1 sheet (nếu dùng công thức thừ rất lâu)

Cứ viết code dùng hàm Trim đi bạn (Application.Trim).
Tuy nhiên phải cẩn thận nếu trên sheet có công thức. Bạn phải chừa những cells chứa công thức ra, còn lại thì Trim hết (chừa cells chứa công thức bằng phương thức SpecialCells)

 

[LienDong]

Cứ viết code dùng hàm Trim đi bạn (Application.Trim).
Tuy nhiên phải cẩn thận nếu trên sheet có công thức. Bạn phải chừa những cells chứa công thức ra, còn lại thì Trim hết (chừa cells chứa công thức bằng phương thức SpecialCells)

Nhờ anh hoặc các bạn khác viết giúp đỡ (chỉ cần vba xóa các khoảng trắng thừa cho khoảng 10 cột)

 

[ndu96081631]

Nhờ anh hoặc các bạn khác viết giúp đỡ (chỉ cần vba xóa các khoảng trắng thừa cho khoảng 10 cột)

Thì ít nhất bạn cũng phải đưa file thật của mình lên đây chứ. Nhiều khi viết xong lại không dùng được, bởi ai mà biết có gì trong "trái ổi" của bạn

 

[LienDong]

Đây file đính kèm, nhờ anh, cảm ơn anh nhiều!

 

[Quang_Hải]

Sub Delete_Redundant_Space()
Dim sArr(), i As Long, j As Long
If Selection.Count = 1 Then End
sArr = Selection.Value
For i = 1 To UBound(sArr)
   For j = 1 To UBound(sArr, 2)
      sArr(i, j) = Application.Trim(sArr(i, j))
   Next
Next
Selection.Value = sArr
End Sub

Bạn copy thử code này. Bôi đen vùng cần xử lý và chạy code

 

[LienDong]

Cảm ơn bạn nhiều!