Gom dữ liệu từ nhiều cột thành một cột duy nhất.

[xsim_vn]

Nhờ AE giúp đỡ mình a.!!
Mình có nhiều cột chứ nội dung là các số
vd:
cột A có nội dung là 1,2,3
cột B có nội dung là 2,3,4
cột C có nội dung là 5,6,7
Mình muốn gom nội dung lại thành một cột duy nhất là A chứa 1,2,3,4,5,6,7
Dùng chức năng copy - dán thì rất lâu ạ..
Xin cám ơn AE rất nhiều...

 

[Lê Duy Thương]

nhờ ae giúp đỡ mình a.!!
Mình có nhiều cột chứ nội dung là các số
vd:
Cột a có nội dung là 1,2,3
cột b có nội dung là 2,3,4
cột c có nội dung là 5,6,7
mình muốn gom nội dung lại thành một cột duy nhất là a chứa 1,2,3,4,5,6,7
dùng chức năng copy - dán thì rất lâu ạ..
Xin cám ơn ae rất nhiều...

chắc dùng tạm code này xem sao

 

[xsim_vn]

chép dán vào rồi bấm RUN phải không vậy bạn??
Sao nó không chạy nhỉ, nó hiện ra bảng báo lỗi VBA

 

[ptm0412]

Code chạy bình thường, ra kết quả đúng. Lại còn sắp xếp lại kết quả nữa.
Tuy nhiên, câu lệnh sort là VBA 2007, 2010, Excel 2003 chạy sẽ bị lỗi.

To Lê Duy Thương:

1. Đối với sort, chỉ cần sort, không cần filter rồi mới sort.

2. Ngoài ra, đã dùng Dic, sao không gán dic xuống sheet cho khoẻ? hoặc dùng mảng và gán mảng xuống sheet?

3. Lại còn câu lệnh này: Select từng ô làm chi cho hao tổn thân gầy?

For Each clls In Range("A1:D" & [A3000].End(3).Row() + 5)
[COLOR=#ff0000]    clls.Select[/COLOR]

4. Sửa Application.ScreenUpdating = False sau đó không trả lại như cũ?

5. Dùng Dic, thì phải xét thêm nếu không rỗng mới add.

6. Dữ liệu có 4 cột, xét làm chi đến 5 cột từ A đến E?

7. Kết quả có 1 cột H, xoá làm chi 6 cột từ E đến J?

Code chỉ cần như vầy:

Sub SAPXEP()
Application.ScreenUpdating = False
Sheets("sheet1").Range("H1:H3000").Clear
  Dim clls As Range, Dic, i As Long
  Set Dic = CreateObject("Scripting.Dictionary")
  For Each clls In Range("A1:D" & [A3000].End(3).Row() + 5)
    If Not Dic.Exists(clls.Value) And clls <> "" Then
      Dic.Add clls.Value, ""
      i = i + 1
    End If
  Next
With Range("H6").Resize(i, 1)
 .Value = Application.Transpose(Dic.keys)
 .Sort Key1:=Range("H6"), Order1:=xlAscending, Header:=xlNo
End With
Application.ScreenUpdating = True
End Sub

 

[Lê Duy Thương]

cảm ơn sư phụ đã chỉ giáo.xin hỏi thêm sư phụ
hai hòng lệnh
Cells(i + 5, "H") = clls.Value và Application.Transpose(Dic.keys) sẽ khác nhau như thế nào
mà khi đệ tử test thì tốc độ giống nhau
đã sửa lại

Sub SAPXEP()
Application.ScreenUpdating = False
Sheets("sheet1").Range("h3:h60000").Clear
  Dim clls As Range, Dic, i As Long
  Set Dic = CreateObject("Scripting.Dictionary")
  For Each clls In Range("A1:d" & [A60000].End(3).Row() + 5)
    If Not Dic.Exists(clls.Value) Then
      Dic.Add clls.Value, ""
      i = i + 1
      Cells(i + 5, "H") = clls.Value
       End If
  Next
  Range("H6").Sort Key1:=Range("H6"), Order1:=xlAscending, Header:=xlNo
   Application.ScreenUpdating = True
End Sub

 

[ptm0412]

Test thử với 50.000 dòng sẽ thấy khác biệt. Dùng timer để tính thời gian:

Sub Test()
t = Timer
...code ...
Range("H1") = Timer - t
End Sub