Copy ô lẻ tẻ và thực hiện Paste Value sang bên cạnh.

[cantl]

Tình hình căng quá các bác ạ,
Em có 1 bí ẩn của khoa học là:
- Copy các ô lẻ lẻ và dán value sang bên cạnh "n" cột.
- Lần lượt dán 10 lần.
Nhờ các bác viết giúp em code ngắn gọn và khoa học hơn, em viết xong mà thấy dài dai dỏm dở quá.

Option Explicit

Sub PasteV()
    Application.ScreenUpdating = False
    Dim StrSel As String
    Dim RgSub As Range, RgSubtemp As Range, cell As Range
    Dim i As Integer, x As Integer, z As Integer
    Dim SoCot As Integer
    Dim RgArr() As String
    Dim tmr As Double
    tmr = Timer
    StrSel = Selection.Address
    ReDim RgArr(1 To Selection.Count)
    RgArr = Split(StrSel, ",")
    SoCot = Application.InputBox("Muon sang may o nao???", , 1, , , , , 1)
    For i = 1 To 10
        For x = 0 To UBound(RgArr(), 1)
            Range(RgArr(x)).Copy
            Range(RgArr(x)).Offset(0, SoCot).PasteSpecial xlPasteValues
            z = z + 1
            Set RgSubtemp = Range(RgArr(x))
            If RgSub Is Nothing Then
                Set RgSub = RgSubtemp
            Else
                Set RgSub = Union(RgSub, Range(RgArr(x)))
            End If
            Debug.Print RgSub.Address
        Next x
    Next i
    MsgBox "Chay het " & z & " lan trong " & Timer - tmr & " s!!!"
    RgSub.Select
    Application.ScreenUpdating = True
End Sub

 

[Nhattanktnn]

Tình hình căng quá các bác ạ,
Em có 1 bí ẩn của khoa học là:
- Copy các ô lẻ lẻ và dán value sang bên cạnh "n" cột.
- Lần lượt dán 10 lần.
Nhờ các bác viết giúp em code ngắn gọn và khoa học hơn, em viết xong mà thấy dài dai dỏm dở quá.

View attachment 294629

Option Explicit

Sub PasteV()
    Application.ScreenUpdating = False
    Dim StrSel As String
    Dim RgSub As Range, RgSubtemp As Range, cell As Range
    Dim i As Integer, x As Integer, z As Integer
    Dim SoCot As Integer
    Dim RgArr() As String
    Dim tmr As Double
    tmr = Timer
    StrSel = Selection.Address
    ReDim RgArr(1 To Selection.Count)
    RgArr = Split(StrSel, ",")
    SoCot = Application.InputBox("Muon sang may o nao???", , 1, , , , , 1)
    For i = 1 To 10
        For x = 0 To UBound(RgArr(), 1)
            Range(RgArr(x)).Copy
            Range(RgArr(x)).Offset(0, SoCot).PasteSpecial xlPasteValues
            z = z + 1
            Set RgSubtemp = Range(RgArr(x))
            If RgSub Is Nothing Then
                Set RgSub = RgSubtemp
            Else
                Set RgSub = Union(RgSub, Range(RgArr(x)))
            End If
            Debug.Print RgSub.Address
        Next x
    Next i
    MsgBox "Chay het " & z & " lan trong " & Timer - tmr & " s!!!"
    RgSub.Select
    Application.ScreenUpdating = True
End Sub

Mà bài toán tổng quát là thế nào, hay chỉ nghịch chơi. Giữa các giá trị copy có giá trị gì khác không hay là rỗng?

 

[htin1997]

Em sẽ làm kiểu này, Copy và dán Skipblanks.

Sub Macro4()
Dim socot As Integer
Dim curcol As Integer
Dim i As Integer
curcol = ActiveCell.Column
Columns(curcol).Copy
socot = Application.InputBox("Nhap so cot", , , , , , , 1)
    For i = 1 To 10
       Columns(curcol).Copy
        Columns(ActiveCell.Column + socot).Select
        Selection.PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True
    Next
End Sub

 

[cantl]

Mà bài toán tổng quát là thế nào, hay chỉ nghịch chơi. Giữa các giá trị copy có giá trị gì khác không hay là rỗng?

Tổng quát là mình không muốn dùng tham chiếu vòng, nên sẽ dán giá trị sang để các ô công thức khác link vào đấy. Thứ tự công việc thế này:
- Chọn cell lẻ tẻ.
- Chọn khoảng cách để paste value sang bên cạnh miễn sao không đè vào ô đã có dữ liệu (sẽ nhập bằng inputbox) (như ảnh là cách 5 cột).
- Paste value 10 lần.
- Mặc định sẽ chọn lại các cell lẻ tẻ ban đầu để có thể cần chạy tiếp thêm 1, 2 lần nữa.

Mình viết nó chạy lâu, mất gần 10 giây cho 6x10 = 60 lần for ... next ...
Cũng là vừa nghịch, vừa tập viết luôn nên dài, chậm.

Bài đã được tự động gộp: 8/9/23

Em sẽ làm kiểu này, Copy và dán Skipblanks.

Sub Macro4()
Dim socot As Integer
Dim curcol As Integer
Dim i As Integer
curcol = ActiveCell.Column
Columns(curcol).Copy
socot = Application.InputBox("Nhap so cot", , , , , , , 1)
    For i = 1 To 10
       Columns(curcol).Copy
        Columns(ActiveCell.Column + socot).Select
        Selection.PasteSpecial Paste:=xlPasteValues, SkipBlanks:=True
    Next
End Sub

Ồ, nhanh thật đấy, chớp cái là xong. Nhưng chưa đúng ý lắm, vì phải paste value 10 lần vào cùng 1 vị trí cơ.

 

[Nhattanktnn]

dán giá trị sang để các ô công thức khác link vào đấy

Do bạn nói không rõ cái đích đến sau cùng là gì nên cũng lười suy nghĩ cho các ý nghĩ vu vơ. Tại vì công thức khác link vào cái ô đã dán thì việc gì phải dán 10 lần? Công thức thì nó chỉ nhận giá trị cuối cùng thôi. Còn nếu là mỗi lần dán -> công thức liên kết tới ô đó thay đổi giá trị -> code bắt lấy giá trị của công thức đó thì sao không xử lý ngay trong code luôn khỏi phải công thức làm gì.
Còn 10s là do nó đợi inputbox của bạn chứ không lâu thế đâu.
Mà vẫn nếu muốn dán từng ô thì cùng lắm là đưa vào mảng gán 1 lần cho mỗi lượt, chắc nhanh hơn chút

 

[VetMini]

Thứ tự công việc thế này:
- Chọn cell lẻ tẻ.
Dùng Ctrl+click để chọn các cells lẻ tẻ.
Sau khi chọn xong thì Selection là Union của các cells đã chọn.
Để khỏi bị lộn xộn mất dấu, ghi nó vào một biến:
Set svSel = Selection
- Chọn khoảng cách để paste value sang bên cạnh miễn sao không đè vào ô đã có dữ liệu (sẽ nhập bằng inputbox) (như ảnh là cách 5 cột).
Input trị soCot
- Paste value 10 lần.
For Luot = 1 to 10
' code paste
For Each rg In svSel
rg.OffSet(0, soCot).Value = rg.Value
Next rg
Next Luot
- Mặc định sẽ chọn lại các cell lẻ tẻ ban đầu để có thể cần chạy tiếp thêm 1, 2 lần nữa.
Như đã được save lại ở trên, nó là svSel
Để chạy thêm 1, 2 lần nữa thì đặt tất cả code trên vào vòng lặp:
Set svSel = Selection
Do
socot = Application.InputBox("Nhap so cot (0 để châm dứt)", , , , , , , 1)
if soCot < 1 Then Exit Do
' code paste 10 lần ở đây
Loop

Bạn hỏi gì tôi trả lời nấy, việc paste 10 lần có vô lý hay không tôi không bàn tới.

 

[cantl]

Selection là Union

rg.OffSet(0, soCot).Value = rg.Value

Chào bác,
- Gợi ý 1 code ngắn hơn, em test Selection trong Immediate thì ra giá trị nên em không nghĩ nó đã Union sẵn.
- Gợi ý 2 gán trực tiếp nên tốc độ nhanh hơn rất nhiều. Copy/paste value sau khi chạy xong còn phải treo máy 1 lúc mới hiện Msgbox nên quá chậm.

đích đến sau cùng

Tớ đang có cái công thức như ảnh và file. Tại sao có công thức đấy thì bỏ qua không xét đến nhé. Vấn đề ở đây là phải làm sao cho hội tụ về 0, nên phải làm 40 lần.

Dùng tham chiếu vòng cũng được nhưng tớ không thích vì sợ không kiểm soát được nhầm tham chiếu ô thì bị sai.

Và file này tớ sửa code theo ý bác VetMini, ngắn hơn và tốc độ nhanh hơn nhiều.

Sub PasteV2()
    Application.ScreenUpdating = False
    Dim cell As Range, svSel As Range
    Dim i As Integer, z As Integer
    Dim SoCot As Integer
    Dim tmr As Double
    tmr = Timer
    Set svSel = Selection
    SoCot = 1
    'SoCot = Application.InputBox("Muon sang may o nao???", , 1, , , , , 1)
    For i = 1 To 40
        For Each cell In svSel
            cell.Offset(0, SoCot).Value = cell.Value
            z = z + 1
        Next cell
    Next i
    MsgBox "Chay het " & z & " lan trong " & Timer - tmr & " s!!!"
    svSel.Select
    Application.ScreenUpdating = True
End Sub