Xếp chuỗi các cột.

[whitelight]

Mình muốn xếp các cột từ 1 -13 thành 1 cột giữ nguyên vị trí các ô và các ô trống thì thêm số 0.Mọi người giúp đỡ nhé

 

[MinhCong]

Mình muốn xếp các cột từ 1 -13 thành 1 cột giữ nguyên vị trí các ô và các ô trống thì thêm số 0.Mọi người giúp đỡ nhé

Nói rõ hơn tí nữa đi Bạn. Muốn xếp như thế nào?

 

[whitelight]

Mình up lên ví dụ trong bảng excel bạn xem giúp nhé.Tức là từ nhiều cột xếp lại thành 1 cột.Trong các cột có nhg ô trống thì điền thêm sô 0.

 

[dat_butmuc]

Mình up lên ví dụ trong bảng excel bạn xem giúp nhé.Tức là từ nhiều cột xếp lại thành 1 cột.Trong các cột có nhg ô trống thì điền thêm sô 0.

Tại ô N2 bạn dùng công thức sau rồi kéo đến dòng thứ 313 xem kết quả ra sao?

=OFFSET($A$2,MOD(ROW()-2,24),INT((ROW()-2)/24))

 

[whitelight]

Cám ơn bạn nhé.Mình muốn hỏi xem ai có cách khác không vì cách trên mình ko hiểu lệnh,mình có rất nhiều bảng có số hàng số cột khác nhau.Nếu thêm số 0 phức tap thì mọi người chỉ hộ cách xếp cũng được.

 

[ChanhTQ@]

Thêm 1 cách để bạn rọng đường tham khảo

Option Explicit
Sub XepChung1Cot()
 Dim eRw As Long, jJ As Byte, Trong As Boolean
 
 Columns("o:O").Value = "":                  [o1].Value = "GPE"
 eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row
 If Cells(eRw, 13).Value = "" Then
   Cells(eRw, 13).Value = 0:                 Trong = True
 End If
 For jJ = 1 To 13
   Cells(1, jJ).Resize(eRw).Copy Destination:=[o65500].End(xlUp).Offset(1)
 Next jJ
 Columns("O:O").SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 If Trong Then Cells(eRw, 13).Value = ""
End Sub

 

[whitelight]

Mọi người cho hỏi nếu chỉ muốn xếp không thôi thì làm thế nào vậy.Có dùng được lệnh Index trong phần này ko vậy

 

[whitelight]

Option Explicit
Sub XepChung1Cot()
 Dim eRw As Long, jJ As Byte, Trong As Boolean
 
 Columns("o:O").Value = "":                  [o1].Value = "GPE"
 eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row
 If Cells(eRw, 13).Value = "" Then
   Cells(eRw, 13).Value = 0:                 Trong = True
 End If
 For jJ = 1 To 13
   Cells(1, jJ).Resize(eRw).Copy Destination:=[o65500].End(xlUp).Offset(1)
 Next jJ
 Columns("O:O").SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 If Trong Then Cells(eRw, 13).Value = ""
End Sub

Code này mình thấy các cột toàn bằng 0 bị dồn lại cả,nó ko giữ nguyên vị trí

 

[ChanhTQ@]

Ờ hen, Mình còn sót, xin lỗi bạn

Code này mình thấy các cột toàn bằng 0 bị dồn lại cả,nó ko giữ nguyên vị trí

Option Explicit
Sub XepChung1Cot()
 Dim eRw As Long, jJ As Byte, Trong As Boolean
 
 Columns("o:O").Value = "":                  [o1].Value = "GPE"
 eRw = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, _
   SearchDirection:=xlPrevious).Row

 For jJ = 1 To 13
1   If Trong Then
      Cells(eRw, jJ - 1).Value = "":         Trong = False
3   End If
   If Cells(eRw, jJ).Value = "" Then
      Cells(eRw, jJ) = 0:           Trong = True
   End If
   
   Cells(1, jJ).Resize(eRw).Copy Destination:=[o65500].End(xlUp).Offset(1)
 Next jJ
 Columns("O:O").SpecialCells(xlCellTypeBlanks).Select
 Selection.FormulaR1C1 = "0"
 
 If Trong Then Cells(eRw, 13).Value = ""
End Sub

 

[ndu96081631]

Mình muốn xếp các cột từ 1 -13 thành 1 cột giữ nguyên vị trí các ô và các ô trống thì thêm số 0.Mọi người giúp đỡ nhé

Thử code này xem:

Private Sub mArr2One(mRng As Range, Target As Range)
  Dim TmpArr, i As Long, j As Long, n As Long, Arr()
  TmpArr = mRng
  ReDim Arr(1 To mRng.Count)
  For j = LBound(TmpArr, 2) To UBound(TmpArr, 2)
    For i = LBound(TmpArr, 1) To UBound(TmpArr, 1)
      n = n + 1
      Arr(n) = Val(TmpArr(i, j))
    Next
  Next
  Target.Resize(n) = WorksheetFunction.Transpose(Arr)
End Sub

Sub Main()
  mArr2One [A2:M25], [O8]
End Sub

Tốc độ thì.. khỏi bàn ---> nhanh như chớp ---> Thử xem!

 

[whitelight]

Thử code này xem:

Private Sub mArr2One(mRng As Range, Target As Range)
  Dim TmpArr, i As Long, j As Long, n As Long, Arr()
  TmpArr = mRng
  ReDim Arr(1 To mRng.Count)
  For j = LBound(TmpArr, 2) To UBound(TmpArr, 2)
    For i = LBound(TmpArr, 1) To UBound(TmpArr, 1)
      n = n + 1
      Arr(n) = Val(TmpArr(i, j))
    Next
  Next
  Target.Resize(n) = WorksheetFunction.Transpose(Arr)
End Sub

Sub Main()
  mArr2One [A2:M25], [O8]
End Sub

Tốc độ thì.. khỏi bàn ---> nhanh như chớp ---> Thử xem!

Code của bác viết trên 2007 thì phải,cái máy tính em chạy cái 2003 nên không được.Cám ơn bác nhé

 

[ndu96081631]

Code của bác viết trên 2007 thì phải,cái máy tính em chạy cái 2003 nên không được.Cám ơn bác nhé

Có đâu chứ! 2007 hay 2003 đều được tuốt!
Có lẽ bạn đã sai gì đó ---> Muốn biết sai chổ nào, hãy đưa nguyên file không chạy được ấy lên đây