Nếu viết code thì dùng Array mới cho tốc độ nhanh được!
Function RemoveBlanks(ByVal SrcRng As Range)
Dim TmpArr, Arr(), Tmp() As Long, i As Long, j As Long
TmpArr = SrcRng.Value
ReDim Tmp(1 To UBound(TmpArr, 2))
ReDim Arr(1 To UBound(TmpArr, 1), 1 To UBound(TmpArr, 2))
For j = 1 To UBound(TmpArr, 2)
For i = 1 To UBound(TmpArr, 1)
If TmpArr(i, j) <> "" Then
Tmp(j) = Tmp(j) + 1
Arr(Tmp(j), j) = TmpArr(i, j)
End If
Next i
Next j
RemoveBlanks = Arr
End Function
18 ---> Giờ bạn muốn xóa các cell rổng rồi chuyển dữ liệu mới đặt vào cell J1, bạn thêm code sau:Sub Main()
Dim SrcRng As Range, Arr
Set SrcRng = Sheet1.Range("B3:D18")
Arr = RemoveBlanks(SrcRng)
Sheet1.Range("J1").Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr
End Sub
Thêm một cách
Public Sub GomGom()
Dim iCot, Mg(), I, J, K
[f1].CurrentRegion.ClearContents
For I = 2 To 4
iCot = Range(Cells(1, I), Cells(10000, I).End(xlUp)).Value
ReDim Mg(1 To UBound(iCot), 1 To 1)
For J = 1 To UBound(iCot)
If iCot(J, 1) <> vbNullString Then
K = K + 1
Mg(K, 1) = iCot(J, 1)
End If
Next J
[d1].Offset(, I).Resize(K) = Mg
Mg = [w1].Resize(K).Value
K = 0
Next I
End Sub
Anh concogia cho em hỏi đoạn Mg=[W1].resize(k).value có tác dụng gì. Em thấy nếu bỏ đoạn đó đoạn code vẫn chạy rất OK, Mà em thấy cũng lạ là khi anh khai báo biến không bao giờ khai báo kiểu dữ liệu mà chạy vẫn đúng!!!
Híc, lại bị bạn bắt giò nữa rồiAnh concogia cho em hỏi đoạn Mg=[W1].resize(k).value có tác dụng gì. Em thấy nếu bỏ đoạn đó đoạn code vẫn chạy rất OK, Mà em thấy cũng lạ là khi anh khai báo biến không bao giờ khai báo kiểu dữ liệu mà chạy vẫn đúng!!!
To Ndu: Em thích nhất là hàm Removeblanks đó cái đó, em mới biết mình có thể đặt vào Function được. Thanks Ndu
Em, đâu dám đâu tại vì em đang học về array nên mới thấy lạ hỏi anh thôi cảm ơn anh giải thích
Thì em đọc mấy bài của bác SA_QC, thấy PTM thì khuyên nên khai báo biến thì đoạn code sẽ cho tốc độ cao hơn, mà anh khai báo biến thì nó vẫn hiểu theo kiểu là Variant, nếu người mới như em thì đọc không hiểu dẫn đến hơi mơ mơ về kiều dữ liệu, nhằm khi thấy những đoạn code của các anh chị khác viết có khai báo, còn nhằm đoạn thì khôngthì học cũng khó
Em thấy anh Concogia viết code quá trùm đó mà. Thanks anh Concogia đã giải thích mong gặp anh trong sinh nhật GPE
Sub Loc1()
Dim cell As Range, Rng As Range
Dim I, J As Integer
[F1].CurrentRegion.ClearContents
For I = 2 To 4
Set Rng = Range(Cells(1, I), Cells(10000, I).End(xlUp))
For Each cell In Rng.SpecialCells(2)
J = J + 1
Cells(J, I + 4).Value = cell.Value
Next
J = 0
Next I
End SubSub Loc2()
Dim I As Integer
Dim Rng As Range
[F1].CurrentRegion.ClearContents
For I = 2 To 4
Set Rng = Range(Cells(1, I), Cells(10000, I).End(xlUp))
Rng.SpecialCells(2).Copy Cells(1, I + 4)
Next I
End Sub
Code của bạn dùng SpecialCells nên cần phải bẫy lỗi trong trường hợp không có dữ liệu.
Thấy bạn chịu khó nghiên cứu Array, tôi tặng bạn hàm mới dùng được trên vùng dữ liệu không liên tục
Function RemoveBlanks(ParamArray sArray())
Dim Arr(), SubArr, Item, Tmp, lR As Long, lC As Long, lRs As Long, lCs As Long
On Error GoTo ExitFunc
For Each SubArr In sArray
Tmp = SubArr
If lRs < UBound(Tmp, 1) Then lRs = UBound(Tmp, 1)
lCs = lCs + 1
Next
ReDim Arr(1 To lRs, 1 To lCs)
For Each SubArr In sArray
lR = 0: lC = lC + 1: Tmp = SubArr
For Each Item In Tmp
If CStr(Item) <> "" Then
lR = lR + 1
Arr(lR, lC) = Item
End If
Next
Next
RemoveBlanks = Arr
ExitFunc:
End FunctionSub Main()
Dim SrcRng As Range, Arr, TG As Double
TG = Timer
On Error GoTo ExitSub
With Sheet1
.Range("AO4:AS60000").Clear
Arr = RemoveBlanks(.Range("T4:T60000"), .Range("X4:X60000"), .Range("AB4:AB60000"), .Range("AF4:AF60000"), .Range("AJ4:AJ60000"))
.Range("AO4:AS4").Resize(UBound(Arr, 1)).Value = Arr
End With
ExitSub:
MsgBox Timer - TG
End Sub
