Liệt kê dữ liệu theo quy luật cho trước

monavamonava · 18/10/19

Chào các bác, do nhu cầu công việc nên em có kiểu dữ liệu như cột A (Nếu dữ liệu ở cột A nhiều hoặc ít hơn ví dụ mẫu thì kết quả sẽ thay đổi theo tương ứng), kết quả mong muốn xuất ra kiểu dữ liệu có quy luật như "cột B", "C&D". Mong nhận sự hỗ trợ từ các cao thủ có thể bằng hàm, công thức hoặc VBA để có được kết quả nhanh và chính xác. Em làm thủ công nhập tay thấy chậm và dễ nhầm lẫn sai số. Xin cảm ơn!

leonguyenz · 18/10/19

Dùng VBA vậy, code sau

Mã:

Sub CaiGiDay()
Dim sAr As Variant, i As Long, uB As Long, rAr As Variant, x As Byte
With Sheet1
    sAr = Range("A1:A" & Range("A65535").End(xlUp).Row).Value2
    uB = UBound(sAr, 1): Range("B1").Resize(2 * uB, 2).ClearContents
    On Error GoTo ErrIc
    x = CByte(InputBox("Nhap 1 hoac 2: ", "Thông báo"))
    Select Case x
    Case 1
        ReDim rAr(1 To 2 * uB, 1 To 1)
        For i = 1 To uB
            rAr(i, 1) = sAr(i, 1)
            rAr(i + uB, 1) = sAr(uB + 1 - i, 1)
        Next i
        Range("B1").Resize(2 * uB) = rAr
    Case 2
        ReDim rAr(1 To 2 * uB, 1 To 2)
        For i = 1 To uB - 1
            rAr(i, 1) = sAr(i, 1): rAr(i, 2) = sAr(i + 1, 1)
            rAr(i + uB - 1, 1) = sAr(uB + 1 - i, 1)
            rAr(i + uB - 1, 2) = sAr(uB - i, 1)
        Next i
        Range("B1").Resize(2 * uB, 2) = rAr
    Case Else
        MsgBox "Thoi roi ta da xa nhau ..."
    End Select
    Exit Sub
ErrIc:
    MsgBox "Nhap so 1 hoac so 2 thoi"
End With
End Sub

monavamonava · 18/10/19

leonguyenz đã viết:

Dùng VBA vậy, code sau

Mã:

Sub CaiGiDay()
Dim sAr As Variant, i As Long, uB As Long, rAr As Variant, x As Byte
With Sheet1
    sAr = Range("A1:A" & Range("A65535").End(xlUp).Row).Value2
    uB = UBound(sAr, 1): Range("B1").Resize(2 * uB, 2).ClearContents
    On Error GoTo ErrIc
    x = CByte(InputBox("Nhap 1 hoac 2: ", "Thông báo"))
    Select Case x
    Case 1
        ReDim rAr(1 To 2 * uB, 1 To 1)
        For i = 1 To uB
            rAr(i, 1) = sAr(i, 1)
            rAr(i + uB, 1) = sAr(uB + 1 - i, 1)
        Next i
        Range("B1").Resize(2 * uB) = rAr
    Case 2
        ReDim rAr(1 To 2 * uB, 1 To 2)
        For i = 1 To uB - 1
            rAr(i, 1) = sAr(i, 1): rAr(i, 2) = sAr(i + 1, 1)
            rAr(i + uB - 1, 1) = sAr(uB + 1 - i, 1)
            rAr(i + uB - 1, 2) = sAr(uB - i, 1)
        Next i
        Range("B1").Resize(2 * uB, 2) = rAr
    Case Else
        MsgBox "Thoi roi ta da xa nhau ..."
    End Select
    Exit Sub
ErrIc:
    MsgBox "Nhap so 1 hoac so 2 thoi"
End With
End Sub

Tuyệt vời quá! Xin cảm ơn Bác nhiều!

monavamonava · 18/10/19

leonguyenz đã viết:

Dùng VBA vậy, code sau

Mã:

Sub CaiGiDay()
Dim sAr As Variant, i As Long, uB As Long, rAr As Variant, x As Byte
With Sheet1
    sAr = Range("A1:A" & Range("A65535").End(xlUp).Row).Value2
    uB = UBound(sAr, 1): Range("B1").Resize(2 * uB, 2).ClearContents
    On Error GoTo ErrIc
    x = CByte(InputBox("Nhap 1 hoac 2: ", "Thông báo"))
    Select Case x
    Case 1
        ReDim rAr(1 To 2 * uB, 1 To 1)
        For i = 1 To uB
            rAr(i, 1) = sAr(i, 1)
            rAr(i + uB, 1) = sAr(uB + 1 - i, 1)
        Next i
        Range("B1").Resize(2 * uB) = rAr
    Case 2
        ReDim rAr(1 To 2 * uB, 1 To 2)
        For i = 1 To uB - 1
            rAr(i, 1) = sAr(i, 1): rAr(i, 2) = sAr(i + 1, 1)
            rAr(i + uB - 1, 1) = sAr(uB + 1 - i, 1)
            rAr(i + uB - 1, 2) = sAr(uB - i, 1)
        Next i
        Range("B1").Resize(2 * uB, 2) = rAr
    Case Else
        MsgBox "Thoi roi ta da xa nhau ..."
    End Select
    Exit Sub
ErrIc:
    MsgBox "Nhap so 1 hoac so 2 thoi"
End With
End Sub

Có thể không đưa ra lựa chọn mà xuất cùng lúc luôn được không bác

leonguyenz · 18/10/19

monavamonava đã viết:
Có thể không đưa ra lựa chọn mà xuất cùng lúc luôn được không bác

Được, bạn sửa lại code, bỏ InputBox, Select Case và MsgBox, tận dụng 2 vòng lặp đó.

monavamonava · 18/10/19

leonguyenz đã viết:
Được, bạn sửa lại code, bỏ InputBox, Select Case và MsgBox, tận dụng 2 vòng lặp đó.

Em không rành code VBA lắm. Bác bỏ giúp em với...

HieuCD · 18/10/19

monavamonava đã viết:
Chào các bác, do nhu cầu công việc nên em có kiểu dữ liệu như cột A (Nếu dữ liệu ở cột A nhiều hoặc ít hơn ví dụ mẫu thì kết quả sẽ thay đổi theo tương ứng), kết quả mong muốn xuất ra kiểu dữ liệu có quy luật như "cột B", "C&D". Mong nhận sự hỗ trợ từ các cao thủ có thể bằng hàm, công thức hoặc VBA để có được kết quả nhanh và chính xác. Em làm thủ công nhập tay thấy chậm và dễ nhầm lẫn sai số. Xin cảm ơn!

Mã:

E1 =IFERROR(IF(A1="",OFFSET(A1,1-COUNTIF($A$1:A1,"")*2,),A1),"")
F1 =IFERROR(IF(A1="",OFFSET(A1,-COUNTIF($A$1:A1,"")*2,),A1),"")
G1 =IFERROR(IF(A2="",OFFSET(A1,-1-COUNTIF($A$1:A1,"")*2,),A2),"")

Copy xuống

leonguyenz · 18/10/19

monavamonava đã viết:
Em không rành code VBA lắm. Bác bỏ giúp em với...

Tham khảo bài #8 của bác HieuCD sử dụng bằng công thức.
Nếu dùng VBA, code sửa lại như sau:

Mã:

Sub CaiGiDo()
Dim sAr As Variant, i As Long, uB As Long, rAr As Variant
With Sheet1
    sAr = Range("A1:A" & Range("A65535").End(xlUp).Row).Value2
    uB = UBound(sAr, 1): Range("B1:D1000").ClearContents
    ReDim rAr(1 To 2 * uB, 1 To 3)
    For i = 1 To uB
        rAr(i, 1) = sAr(i, 1)
        rAr(i + uB, 1) = sAr(uB + 1 - i, 1)
    Next i

    For i = 1 To uB - 1
        rAr(i, 2) = sAr(i, 1): rAr(i, 3) = sAr(i + 1, 1)
        rAr(i + uB - 1, 2) = sAr(uB + 1 - i, 1)
        rAr(i + uB - 1, 3) = sAr(uB - i, 1)
    Next i
    Range("B1").Resize(2 * uB, 3) = rAr
End With
End Sub

HieuCD · 18/10/19

Thêm cách khác dùng 1 vòng For

Mã:

Sub ABC()
  Dim sArr(), Res(), i&, sRow&
  With Sheet1
    sArr = .Range("A1:A" & .Range("A65535").End(xlUp).Row).Value
    sRow = UBound(sArr, 1)
    ReDim Res(1 To 2 * sRow, 1 To 3)
    For i = 1 To sRow
      Res(i, 1) = sArr(i, 1)
      Res(i + sRow, 1) = sArr(sRow + 1 - i, 1)
      Res(i, 2) = sArr(i, 1)
      If i < sRow Then
        Res(i + sRow, 2) = sArr(sRow - i, 1)
        Res(i, 3) = sArr(i + 1, 1)
        Res(i + sRow - 1, 3) = sArr(sRow - i, 1)
      End If
    Next i
    .Range("B1:D" & .Range("B65535").End(xlUp).Row).ClearContents
    .Range("B1").Resize(2 * sRow, 3) = Res
  End With
End Sub

monavamonava · 18/10/19

HieuCD đã viết:

Thêm cách khác dùng 1 vòng For

Mã:

Sub ABC()
  Dim sArr(), Res(), i&, sRow&
  With Sheet1
    sArr = .Range("A1:A" & .Range("A65535").End(xlUp).Row).Value
    sRow = UBound(sArr, 1)
    ReDim Res(1 To 2 * sRow, 1 To 3)
    For i = 1 To sRow
      Res(i, 1) = sArr(i, 1)
      Res(i + sRow, 1) = sArr(sRow + 1 - i, 1)
      Res(i, 2) = sArr(i, 1)
      If i < sRow Then
        Res(i + sRow, 2) = sArr(sRow - i, 1)
        Res(i, 3) = sArr(i + 1, 1)
        Res(i + sRow - 1, 3) = sArr(sRow - i, 1)
      End If
    Next i
    .Range("B1:D" & .Range("B65535").End(xlUp).Row).ClearContents
    .Range("B1").Resize(2 * sRow, 3) = Res
  End With
End Sub

Trước hết xin cảm ơn tấm lòng bác Hiếu CD đã trợ giúp cả công thức lẫn VBA. Hai cách của bác cho kết quả giống nhau và gần chính xác. Kết quả mong muốn là dòng cuối cùng cột C của bác bị dư. Hay nói cách khác là nó chỉ dừng lại đến hàng của cột D mà thôi. Kết quả như của bác leonguyenz là đúng ạ.

Bài đã được tự động gộp: 18/10/19

leonguyenz đã viết:

Tham khảo bài #8 của bác HieuCD sử dụng bằng công thức.
Nếu dùng VBA, code sửa lại như sau:

Mã:

Sub CaiGiDo()
Dim sAr As Variant, i As Long, uB As Long, rAr As Variant
With Sheet1
    sAr = Range("A1:A" & Range("A65535").End(xlUp).Row).Value2
    uB = UBound(sAr, 1): Range("B1:D1000").ClearContents
    ReDim rAr(1 To 2 * uB, 1 To 3)
    For i = 1 To uB
        rAr(i, 1) = sAr(i, 1)
        rAr(i + uB, 1) = sAr(uB + 1 - i, 1)
    Next i

    For i = 1 To uB - 1
        rAr(i, 2) = sAr(i, 1): rAr(i, 3) = sAr(i + 1, 1)
        rAr(i + uB - 1, 2) = sAr(uB + 1 - i, 1)
        rAr(i + uB - 1, 3) = sAr(uB - i, 1)
    Next i
    Range("B1").Resize(2 * uB, 3) = rAr
End With
End Sub

Xin cảm ơn. VBA này cảu

leonguyenz đã viết:

Tham khảo bài #8 của bác HieuCD sử dụng bằng công thức.
Nếu dùng VBA, code sửa lại như sau:

Mã:

Sub CaiGiDo()
Dim sAr As Variant, i As Long, uB As Long, rAr As Variant
With Sheet1
    sAr = Range("A1:A" & Range("A65535").End(xlUp).Row).Value2
    uB = UBound(sAr, 1): Range("B1:D1000").ClearContents
    ReDim rAr(1 To 2 * uB, 1 To 3)
    For i = 1 To uB
        rAr(i, 1) = sAr(i, 1)
        rAr(i + uB, 1) = sAr(uB + 1 - i, 1)
    Next i

    For i = 1 To uB - 1
        rAr(i, 2) = sAr(i, 1): rAr(i, 3) = sAr(i + 1, 1)
        rAr(i + uB - 1, 2) = sAr(uB + 1 - i, 1)
        rAr(i + uB - 1, 3) = sAr(uB - i, 1)
    Next i
    Range("B1").Resize(2 * uB, 3) = rAr
End With
End Sub

Xin cảm ơn bác nhiều! VBA này đã cho kết quả như mong muốn.

HieuCD · 18/10/19

monavamonava đã viết:
Trước hết xin cảm ơn tấm lòng bác Hiếu CD đã trợ giúp cả công thức lẫn VBA. Hai cách của bác cho kết quả giống nhau và gần chính xác. Kết quả mong muốn là dòng cuối cùng cột C của bác bị dư. Hay nói cách khác là nó chỉ dừng lại đến hàng của cột D mà thôi. Kết quả như của bác leonguyenz là đúng ạ.

Bài đã được tự động gộp: 18/10/19

Xin cảm ơn. VBA này cảu

Xin cảm ơn bác nhiều! VBA này đã cho kết quả như mong muốn.

Mình cố tình dư thêm 1 dòng để kết quả 3 cột có cùng qui luật, lấy tới "A" thì dừng

Liệt kê dữ liệu theo quy luật cho trước

monavamonava

Thành viên thường trực

File đính kèm

leonguyenz

Thành viên gạo cội

File đính kèm

monavamonava

Thành viên thường trực

monavamonava

Thành viên thường trực

leonguyenz

Thành viên gạo cội

monavamonava

Thành viên thường trực

HieuCD

Chuyên gia GPE

File đính kèm

leonguyenz

Thành viên gạo cội

File đính kèm

HieuCD

Chuyên gia GPE

monavamonava

Thành viên thường trực

HieuCD

Chuyên gia GPE

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Đếm ngược thời gian