whitelight
Thành viên chính thức
- Tham gia
- 30/10/08
- Bài viết
- 50
- Được thích
- 0
- Điểm
- 0
Nói rõ hơn tí nữa đi Bạn. Muốn xếp như thế nào?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é
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.
=OFFSET($A$2,MOD(ROW()-2,24),INT((ROW()-2)/24))
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
PHP: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í
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
Thử code này xem: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é
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
Thử code này xem:
PHP: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
Tốc độ thì.. khỏi bàn ---> nhanh như chớp ---> Thử xem!PHP:Sub Main() mArr2One [A2:M25], [O8] End Sub
Có đâu chứ! 2007 hay 2003 đều được tuốt!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é
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2