Code dồn hết dòng lên trên theo STT. (1 người xem)

[toandiennuoc123]

Xin chào ACE trên Diễn đàn. Tôi có 1 vấn đề muốn nhờ ACE giúp đỡ, VD: Có cột A điền STT từ 1-200 cột B (B1:B200) trong 200 dòng đấy có 1 số ô có dữ liệu và 1 số ô không có dữ liệu vì nó dài quá nên bất tiện , tôi muốn dồn dữ liệu cột B sang cột E và cột A sang cột D (đã bị loại hết các dòng trống mà vẫn giữ được STT của dòng có dữ liệu. Xin chân thành cám ơn ACE.

 

[ChanhTQ@]

Macro của bạn đây, thử xem sao.

Option Explicit
Sub gpeDonDuLieuTheoHang()
 Dim Rng As Range, Cls As Range
 
 [D6].CurrentRegion.Offset(1).ClearContents
 Set Rng = Range([B6], [B65500].End(xlUp)).SpecialCells(xlCellTypeConstants, 3)
 For Each Cls In Rng
    With [D65500].End(xlUp).Offset(1)
        .Resize(, 2).Value = Cls.Offset(, -1).Resize(, 2).Value
    End With
 Next Cls
End Sub

 

[Quang_Hải]

Cho mình tham gia 1 code

Sub don_dulieu()
dim dic as Object, i
Set dic = CreateObject("scripting.dictionary")
dulieu = Range([a5], [a65536].End(3)).Resize(, 2).Value
With dic
    For i = 1 To UBound(dulieu, 1)    
          If dulieu(i, 2) <> "" Then .Add dulieu(i, 1), dulieu(i, 2)     
    Next i
    [F5].Resize(.Count, 1) = Application.Transpose(.keys)
    [G5].Resize(.Count, 1) = Application.Transpose(.items)
End With
End Sub

 

[overnight_9]

có phải thiếu cái này không anh Quanghai?

Dim dic As Object, dulieu As Object,

i

 

[ndu96081631]

Thử dùng Advanced Filter xem:

Sub Test()
  Dim Rng As Range, CritRng As Range
  On Error Resume Next
  Set Rng = Sheet1.Range("A5:B10000")
  Set CritRng = Rng.Parent.Range("IV1:IV2")
  Rng.Parent.Range("D5:E10000").ClearContents
  CritRng(1, 1).Value = Rng(1, 2).Value
  CritRng(2, 1).Value = "<>"
  Rng.AdvancedFilter 2, CritRng, Rng.Parent.Range("D5")
  CritRng.ClearContents
End Sub

Công cụ có sẵn, cứ thế mà xài
Ẹc... Ẹc...

 

[Ba Tê]

Thử dùng Advanced Filter xem:

Sub Test()
  Dim Rng As Range, CritRng As Range
  On Error Resume Next
  Set Rng = Sheet1.Range("A5:B10000")
  Set CritRng = Rng.Parent.Range("IV1:IV2")
  Rng.Parent.Range("D5:E10000").ClearContents
  CritRng(1, 1).Value = Rng(1, 2).Value
  CritRng(2, 1).Value = "<>"
  Rng.AdvancedFilter 2, CritRng, Rng.Parent.Range("D5")
  CritRng.ClearContents
End Sub

Công cụ có sẵn, cứ thế mà xài
Ẹc... Ẹc...

Ndu thường "khoái" đưa nó vào 1 mảng rồi "đập" cho nó 1 phát mà ta?

Public Sub GPE()
Dim Rng(), Arr(), I As Long, K As Long
    Rng = Sheet1.Range(Sheet1.[A5], Sheet1.[A65000].End(xlUp)).Resize(, 2).Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 2)
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 2) <> "" Then
            K = K + 1
            Arr(K, 1) = Rng(I, 1): Arr(K, 2) = Rng(I, 2)
        End If
    Next I
Sheet1.[G5:H1000].ClearContents '"Mới thêm dòng này"
If K Then Sheet1.[G5].Resize(K, 2).Value = Arr
End Sub

 

[ndu96081631]

Ndu thường "khoái" đưa nó vào 1 mảng rồi "đập" cho nó 1 phát mà ta?

Public Sub GPE()
Dim Rng(), Arr(), I As Long, K As Long
    Rng = Sheet1.Range(Sheet1.[A5], Sheet1.[A65000].End(xlUp)).Resize(, 2).Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 2)
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 2) <> "" Then
            K = K + 1
            Arr(K, 1) = Rng(I, 1): Arr(K, 2) = Rng(I, 2)
        End If
    Next I
Sheet1.[G5:H1000].ClearContents '"Mới thêm dòng này"
If K Then Sheet1.[G5].Resize(K, 2).Value = Arr
End Sub

Đúng vậy! Nhưng bài này không "xứng" để làm với mảng!
Mảng cho tốc độ cao nhưng Advanced Filter với điều kiện lọc đơn giản cũng có tốc độ không kém đâu nha (nó chỉ chậm khi điều kiện là 1 công thức kết hợp)
Ngoài ra, nếu đã dùng code theo phương pháp Advanced Filter thì cũng đồng nghĩa ta làm bằng tay vô tư
Ẹc... Ẹc...

 

[toandiennuoc123]

Thử dùng Advanced Filter xem:

Sub Test()
  Dim Rng As Range, CritRng As Range
  On Error Resume Next
  Set Rng = Sheet1.Range("A5:B10000")
  Set CritRng = Rng.Parent.Range("IV1:IV2")
  Rng.Parent.Range("D5:E10000").ClearContents
  CritRng(1, 1).Value = Rng(1, 2).Value
  CritRng(2, 1).Value = "<>"
  Rng.AdvancedFilter 2, CritRng, Rng.Parent.Range("D5")
  CritRng.ClearContents
End Sub

Công cụ có sẵn, cứ thế mà xài
Ẹc... Ẹc...

Cám ơn các cao thủ đã ra tay, cái thì bị lech dòng, cái thì bị lỗi không chạy được, của quanghai thì bị ở dòng "Dulieu" trong code, chỉ mỗi của ndu là ngon nhất nhưng lại phát sinh vấn đề: những ô chứa công thức (tập rỗng) xuất hiện toàn số "0" nên không rút gọn được, nó cứ dài bằng dữ liệu ban đầu nên không rút gọn được, nhờ bạn ndu xem hộ nhé. Xin chân thành cám ơn các bạn nhiều.

 

[ndu96081631]

Cám ơn các cao thủ đã ra tay, cái thì bị lech dòng, cái thì bị lỗi không chạy được, của quanghai thì bị ở dòng "Dulieu" trong code, chỉ mỗi của ndu là ngon nhất nhưng lại phát sinh vấn đề: những ô chứa công thức (tập rỗng) xuất hiện toàn số "0" nên không rút gọn được, nó cứ dài bằng dữ liệu ban đầu nên không rút gọn được, nhờ bạn ndu xem hộ nhé. Xin chân thành cám ơn các bạn nhiều.

Cụ thể là như thế nào? Tôi không hình dung được!
Bạn đưa file bạn đang test lên đây (file có công thức gì gì đó)

 

[toandiennuoc123]

Dồn ô trống

Cụ thể là như thế nào? Tôi không hình dung được!
Bạn đưa file bạn đang test lên đây (file có công thức gì gì đó)

Nhờ bạn xem hộ nhé, Công thức chỉ là copy số liệu của sheet khác thôi.

 

[ndu96081631]

Nhờ bạn xem hộ nhé, Công thức chỉ là copy số liệu của sheet khác thôi.

Chài ai...
Lúc xưa là cell trống, ta có điều kiện CritRng(2, 1).Value = "<>" (tức khác rổng)
Giờ các cell trống ấy là số 0, ta sửa lại thành CritRng(2, 1).Value = "<>0" là xong (tức khác 0)

Sub Test()
  Dim Rng As Range, CritRng As Range
  On Error Resume Next
  Set Rng = Sheet1.Range("A5:B10000")
  Set CritRng = Rng.Parent.Range("IV1:IV2")
  Rng.Parent.Range("D5:E10000").ClearContents
  CritRng(1, 1).Value = Rng(1, 2).Value
  [COLOR=#ff0000][B]CritRng(2, 1).Value = "<>0"[/B][/COLOR]
  Rng.AdvancedFilter 2, CritRng, Rng.Parent.Range("D5")
  CritRng.ClearContents
End Sub

 

[Ba Tê]

Chài ai...
Lúc xưa là cell trống, ta có điều kiện CritRng(2, 1).Value = "<>" (tức khác rổng)
Giờ các cell trống ấy là số 0, ta sửa lại thành CritRng(2, 1).Value = "<>0" là xong (tức khác 0)

Sub Test()
  Dim Rng As Range, CritRng As Range
  On Error Resume Next
  Set Rng = Sheet1.Range("A5:B10000")
  Set CritRng = Rng.Parent.Range("IV1:IV2")
  Rng.Parent.Range("D5:E10000").ClearContents
  CritRng(1, 1).Value = Rng(1, 2).Value
  [COLOR=#ff0000][B]CritRng(2, 1).Value = "<>0"[/B][/COLOR]
  Rng.AdvancedFilter 2, CritRng, Rng.Parent.Range("D5")
  CritRng.ClearContents
End Sub

Chài...ai!
Cái này cũng bị lỗi sao ta?

Public Sub GPE()
Dim Rng(), Arr(), I As Long, K As Long
    Rng = Sheet1.Range(Sheet1.[A5], Sheet1.[A65000].End(xlUp)).Resize(, 2).Value
ReDim Arr(1 To UBound(Rng, 1), 1 To 2)
    For I = 1 To UBound(Rng, 1)
        If Rng(I, 2) <> 0 Then
            K = K + 1
            Arr(K, 1) = Rng(I, 1): Arr(K, 2) = Rng(I, 2)
        End If
    Next I
Sheet1.[G5:H1000].ClearContents
If K Then Sheet1.[G5].Resize(K, 2).Value = Arr
End Sub

 

[toandiennuoc123]

Chài ai...
Lúc xưa là cell trống, ta có điều kiện CritRng(2, 1).Value = "<>" (tức khác rổng)
Giờ các cell trống ấy là số 0, ta sửa lại thành CritRng(2, 1).Value = "<>0" là xong (tức khác 0)

Sub Test()
  Dim Rng As Range, CritRng As Range
  On Error Resume Next
  Set Rng = Sheet1.Range("A5:B10000")
  Set CritRng = Rng.Parent.Range("IV1:IV2")
  Rng.Parent.Range("D5:E10000").ClearContents
  CritRng(1, 1).Value = Rng(1, 2).Value
  [COLOR=#ff0000][B]CritRng(2, 1).Value = "<>0"[/B][/COLOR]
  Rng.AdvancedFilter 2, CritRng, Rng.Parent.Range("D5")
  CritRng.ClearContents
End Sub

Cám ơn bạn ndu nhiểu nhé, thât đơn giản mà khó biêt.