Đảo ngược thứ tự giá trị các ô (1 người xem)

[Nam CT]

Sub xapxep()
Dim cell As Range
Dim tg As Range
Dim x As Double
For Each cell In Selection
For Each tg In Selection.Offset(0, 1)
x = cell
cell = tg
tg = x
Next tg
Next cell
End Sub
Em muốn đảo ngược thứ tự giá trị các ô được chọn sang ô bên cạnh nhưng vẫn giữ nguyên giá trị ở vùng được chọn ban đầu.

 

[dhn46]

Không biết có phải bạn muốn như thế này không?

Sub SapXep()
    Dim Arr
    Dim i As Long, j As Long, Tmp As Double
    Arr = Sheet1.Range("A1:A14")
    For i = 2 To UBound(Arr, 1)
        For j = 1 To UBound(Arr, 1) - 1
            If Arr(j, 1) < Arr(i, 1) Then
                Tmp = Arr(i, 1)
                Arr(i, 1) = Arr(j, 1)
                Arr(j, 1) = Tmp
            End If
        Next
    Next
    Sheet1.Range("B1").Resize(UBound(Arr, 1), 1) = Arr
End Sub

 

[Quang_Hải]

Sub xapxep()
Dim cell As Range
Dim tg As Range
Dim x As Double
For Each cell In Selection
For Each tg In Selection.Offset(0, 1)
x = cell
cell = tg
tg = x
Next tg
Next cell
End Sub
Em muốn đảo ngược thứ tự giá trị các ô được chọn sang ô bên cạnh nhưng vẫn giữ nguyên giá trị ở vùng được chọn ban đầu.

Sửa tạm vầy coi sao nhá

Sub xapxep()
Dim cell As Range
Dim tg As Range
Dim x As Double
Dim TAM
TAM = Selection
For Each cell In Selection
   For Each tg In Selection.Offset(0, 1)
      x = cell
      cell = tg
      tg = x
   Next tg
Next cell
Selection = TAM
End Sub

 

[Nam CT]

Sửa tạm vầy coi sao nhá

Sub xapxep()
Dim cell As Range
Dim tg As Range
Dim x As Double
Dim TAM
TAM = Selection
For Each cell In Selection
   For Each tg In Selection.Offset(0, 1)
      x = cell
      cell = tg
      tg = x
   Next tg
Next cell
Selection = TAM
End Sub

Cảm ơn bác nhé, e loay hoay mãi

 

[VetMini]

Nếu chỉ đơn giản copy sang cột bên cạnh và đảo ngược thứ tự thì chỉ cần 1 vòng lặp thôi.

Dim i As Integer
For i = 1 To Selection.Rows.Count
Selection.Offset(0, 1).Cells(Selection.Rows.Count - i + 1) = Selection.Cells(i)
Next i

đương nhiên để tránh tình trạng chọn nhằm nhiều cột hì phải thêm phần code loại trừ nhiều cột đi.

If Selection.Columns.Count <> 1 Then
MsgBox "Vung chon co " & Selection.Columns.Count _
& " cot. Khong dao nguoc duoc"
End If

 

[siwtom]

Sub xapxep()
Dim cell As Range
Dim tg As Range
Dim x As Double
For Each cell In Selection
For Each tg In Selection.Offset(0, 1)
x = cell
cell = tg
tg = x
Next tg
Next cell
End Sub
Em muốn đảo ngược thứ tự giá trị các ô được chọn sang ô bên cạnh nhưng vẫn giữ nguyên giá trị ở vùng được chọn ban đầu.

Sub xapxep()
Dim a As Long, cell As Range
    a = 2 * Selection.Row + Selection.Count - 1
    For Each cell In Selection
        cell.Offset(a - 2 * cell.Row, 1) = cell
    Next
End Sub

Nếu ta cần xử lý trường hợp chọn nhiều cột thì tùy vào cách xử lý mà code sẽ khác nhau. Vd. hiển thị MsgBox và không làm gì. Nhưng cũng có thể xử lý bằng cách: có thể chọn 1 hoặc nhiều cột nhưng chỉ có cột đầu được xét.

Sub xapxep()
Dim a As Long, cell As Range, rng As Range
    Set rng = Selection.Resize(, 1)
    a = 2 * rng.Row + rng.Count - 1
    For Each cell In rng
        cell.Offset(a - 2 * cell.Row, 1) = cell
    Next
End Sub

 

[Quang_Hải]

Hay là xài mảng cho nói oai thêm tí

Sub yyy()
Dim i, j, tam(), kq()
tam = Selection.Value
ReDim kq(1 To UBound(tam), 1 To 1)
For i = UBound(tam) To 1 Step -1
   j = j + 1
   kq(j, 1) = tam(i, 1)
Next
Selection.Offset(, 1) = kq
End Sub

 

[akayzai1]

bác quang hải qua topic sửa hộ e code bài sắp xếp số nhé

 

[siwtom]

Hay là xài mảng cho nói oai thêm tí

Sub yyy()
Dim i, j, tam(), kq()
tam = Selection.Value
ReDim kq(1 To UBound(tam), 1 To 1)
For i = UBound(tam) To 1 Step -1
   j = j + 1
   kq(j, 1) = tam(i, 1)
Next
Selection.Offset(, 1) = kq
End Sub

Đâu chỉ có oai hả bạn (dùng 1 "hả bạn" thôi nhé. He he). Code là 1 trong số các code hay.
Tất nhiên phải xử lý trường hợp Selection = 1 ô (tam = Selection.Value sẽ có lỗi), và khi chọn >= 2 cột.

Cũng có thể dùng 1 mảng. Code sau có cả xử lý chọn 1 ô hoặc >= 2 cột.

Sub yyy()
Dim i As Long, a As Long, x, tam()
    If Selection.Count = 1 Then
        Selection.Offset(, 1) = Selection
        Exit Sub
    Else
        tam = Selection.Value
        ReDim Preserve tam(1 To UBound(tam), 1 To 1)
        a = UBound(tam) + 1
        For i = 1 To UBound(tam) \ 2
           x = tam(i, 1)
           tam(i, 1) = tam(a - i, 1)
           tam(a - i, 1) = x
        Next
        Selection.Resize(, 1).Offset(, 1) = tam
    End If
End Sub

 

[thanhlanh]

Đâu chỉ có oai hả bạn (dùng 1 "hả bạn" thôi nhé. He he). Code là 1 trong số các code hay.
Tất nhiên phải xử lý trường hợp Selection = 1 ô (tam = Selection.Value sẽ có lỗi), và khi chọn >= 2 cột.

Cũng có thể dùng 1 mảng. Code sau có cả xử lý chọn 1 ô hoặc >= 2 cột.

Sub yyy()
Dim i As Long, a As Long, x, tam()
    If Selection.Count = 1 Then
        Selection.Offset(, 1) = Selection
        Exit Sub
    Else
        tam = Selection.Value
        [B][COLOR=#ff0000]ReDim Preserve tam(1 To UBound(tam), 1 To 1)[/COLOR][/B]
        a = UBound(tam) + 1
        For i = 1 To UBound(tam) \ 2
           x = tam(i, 1)
           tam(i, 1) = tam(a - i, 1)
           tam(a - i, 1) = x
        Next
        Selection.Resize(, 1).Offset(, 1) = tam
    End If
End Sub

Hay, nhưng hình như dư dòng màu đỏ rồi anh ơi!

 

[siwtom]

Hay, nhưng hình như dư dòng màu đỏ rồi anh ơi!

Ờ đúng. Viết xong cũng chả test nên không phát hiện ra. Đỏ đỏ không cần vì đã có Selection.Resize(, 1).Offset(, 1) = tam

 

[nginh]

Em muốn đảo ngược thứ tự giá trị các ô được chọn sang ô bên cạnh nhưng vẫn giữ nguyên giá trị ở vùng được chọn ban đầu.

Giả sử vùng chọn là B2:B9, gõ CT sau cho ô C2

=OFFSET(B$2,ROW(B$9)-ROW(B2),0)

kéo xuống C9

 

[siwtom]

Giả sử vùng chọn là B2:B9, gõ CT sau cho ô C2

=OFFSET(B$2,ROW(B$9)-ROW(B2),0)

kéo xuống C9

Đây là box "Lập trình" mà bạn

 

[nginh]

Đây là box "Lập trình" mà bạn

Có thể lập trình theo công thức trên

Sub Inv()
Dim s As Range, cell As Range
Set s = Selection
For Each cell In s.Offset(, 1)
cell = s(1).Offset(s(s.Rows.Count).Row - cell.Row)
Next
End Sub