Nhờ sửa giùm 2 lỗi trong đoạn code copy dữ liệu từ nhiều hàng thành 1 hàng và 1 cột

[liro]

Đoạn code này em dựa trên sách Lập trình VBA tuy nhiên vẫn còn lỗi khi dùng. Mong mọi người chỉ cách sửa hộ em. Lỗi em đã ghi trong file đính kèm

 

[SA_DQ]

Bạn tham khảo thử 1 cái trước nha.

Sub ChuyenNhieuCotThanh1Cot()
'Dung de copy nhieu cot chuyen thanh 1 cot duy nhat
 Dim Rws As Long, zZ As Long:          Dim Clls As Range
 Dim Col As Integer, Jj As Integer
Col = Selection.Columns.Count
Rws = Selection.Rows.Count
Set Clls = Cells(65500, Selection.Cells(1, Col).Column + 2).End(xlUp)
Clls.Value = "K Qua:"
For zZ = 1 To Col
    For Jj = 1 To Rws
      With Cells(65500, Clls.Column).End(xlUp).Offset(1)
        If Selection.Cells(Jj, zZ) <> "" Then
            .Value = Selection.Cells(Jj, zZ)
        End If
      End With
    Next Jj
Next zZ
Clls.Select
End Sub

 

[ndu96081631]

Đoạn code này em dựa trên sách Lập trình VBA tuy nhiên vẫn còn lỗi khi dùng. Mong mọi người chỉ cách sửa hộ em. Lỗi em đã ghi trong file đính kèm

Tằng bạn món đồ chơi này:

Sub OneLine(SrcRng As Range, Target As Range, Optional Way As Boolean = True)
  'Copy thanh cot thì Way = true và nguoc lai
  Dim i As Long, j As Long, k As Long, iCount As Long
  Dim Arr(), TmpRng As Range, Clls As Range
  With SrcRng
    For i = 1 To .Areas.Count
      iCount = IIf(Way, .Areas(i).Columns.Count, .Areas(i).Rows.Count)
      For j = 1 To iCount
        If Way Then
          Set TmpRng = .Areas(i).Resize(, 1).Offset(, j - 1)
        Else
          Set TmpRng = .Areas(i).Resize(1).Offset(j - 1)
        End If
        For Each Clls In TmpRng
          If Not IsEmpty(Clls) Then
            ReDim Preserve Arr(k)
            Arr(k) = Clls.Value
            k = k + 1
          End If
        Next Clls
      Next j
    Next i
  End With
  If k > 0 Then _
    Target.Resize(k ^ (-Way), k / (k ^ (-Way))) = IIf(Way, WorksheetFunction.Transpose(Arr), Arr)
End Sub

Từ giờ trở đi ta có thể "quên" đoạn code trên, chỉ cần biết cách áp dụng mà thôi:
- Giả sử bạn muốn copy vùng B813
- Đặt kết quả vào cell H8
- Chuyển các cột thành 1 cột
thì ta viết thêm 1 sub thế này:

Sub ChuyenThanhCot()
  OneLine [B8:D13], [H8], True
End Sub

- Để chuyển các dòng thành 1 dòng

Sub ChuyenThanhDong()
  OneLine [B8:D13], [H8], False
End Sub

vân vân...
Code tuy dài nhưng bảo đảm với bạn tốc độ cực nhanh và mức độ tùy biến rất cao!
Đặc biết cho phép copy nhiều vùng không liên tục luôn.. ví dụ: Copy vùng B813 và B1823 đặt vào H8 thì ta sẽ viết

Sub ChuyenThanhCot()
  OneLine Union([B8:D13],[B18:D23]), [H8], True
End Sub

(Đúng ra dùng SpecialCells sẽ cho tốc độ cao hơn nữa, nhưng vì phương pháp này tiềm ẩn nguy cơ gây lỗi nên tôi không áp dụng)

 

[anhtotbung35]

Tằng bạn món đồ chơi này:

Sub OneLine(SrcRng As Range, Target As Range, Optional Way As Boolean = True)
'Copy thanh cot thì Way = true và nguoc lai
Dim i As Long, j As Long, k As Long, iCount As Long
Dim Arr(), TmpRng As Range, Clls As Range
With SrcRng
For i = 1 To .Areas.Count
iCount = IIf(Way, .Areas(i).Columns.Count, .Areas(i).Rows.Count)
For j = 1 To iCount
If Way Then
Set TmpRng = .Areas(i).Resize(, 1).Offset(, j - 1)
Else
Set TmpRng = .Areas(i).Resize(1).Offset(j - 1)
End If
For Each Clls In TmpRng
If Not IsEmpty(Clls) Then
ReDim Preserve Arr(k)
Arr(k) = Clls.Value
k = k + 1
End If
Next Clls
Next j
Next i
End With
If k > 0 Then _
Target.Resize(k ^ (-Way), k / (k ^ (-Way))) = IIf(Way, WorksheetFunction.Transpose(Arr), Arr)
End Sub

Từ giờ trở đi ta có thể "quên" đoạn code trên, chỉ cần biết cách áp dụng mà thôi:
- Giả sử bạn muốn copy vùng B813
- Đặt kết quả vào cell H8
- Chuyển các cột thành 1 cột
thì ta viết thêm 1 sub thế này:

Sub ChuyenThanhCot()
OneLine [B8:D13], [H8], True
End Sub

- Để chuyển các dòng thành 1 dòng

Sub ChuyenThanhDong()
OneLine [B8:D13], [H8], False
End Sub

vân vân...
Code tuy dài nhưng bảo đảm với bạn tốc độ cực nhanh và mức độ tùy biến rất cao!
Đặc biết cho phép copy nhiều vùng không liên tục luôn.. ví dụ: Copy vùng B813 và B1823 đặt vào H8 thì ta sẽ viết

Sub ChuyenThanhCot()
OneLine Union([B8:D13],[B18:D23]), [H8], True
End Sub

(Đúng ra dùng SpecialCells sẽ cho tốc độ cao hơn nữa, nhưng vì phương pháp này tiềm ẩn nguy cơ gây lỗi nên tôi không áp dụng)

Cho em hỏi trong đoạn code của anh Ndu thì để thực hiện lệnh phải Click vào nút lệnh, em muốn trong một module khác viết lệnh chọn một ô nào đó và cho tự động thực hiện code này thì phải viết thế nào.