GIúp sửa code tách dữ liệu 1 vùng sang 1 bảng dữ liệu (1 người xem)

[minhtuan55]

Chào cả nhà GPE !
Em có dùng 1 đoạn code bên dưới dùng để tách dữ liệu từ 1 vùng sang 1 bảng dữ liệu. Khổ nổi code này em lúc trước em dùng cho trường hợp tách ra rồi nếu Trùng tên hàng thì CỘng dồn SL, Đơn giá, Thành tiền lại với nhau thì OK không có sai cả, mà giờ em muốn dùng cho trường hợp chỉ tách ra thôi không cần cộng dồn thì không biết sửa làm sao, em mò gần 3 tiếng sữa đi sữa lại vẫn không được. Code này là của anh Ba TÊ mong anh và mọi người sửa lại giúp em

Hiện tại em đang dùng Code của anh ndu96081631. Code anh Ndu thì OK nhưng nhược điểm là khi em ẩn cái cột dữ liệu ( cần tách ) đi thì nó lại báo lỗi không xuất ra được cái gì hếtXem tại bài : http://www.giaiphapexcel.com/forum/...Giúp-sửa-code-lọc-1-chuỗi-sang-1-bảng-dữ-liệu

' hien tai Code nay Tach xong roi Cong don luon, em Muon sua lai Chi Tach ra thoi khong can Cong don
Sub tachdulieu()
Dim sArr(), dArr(), Tmp, Tem, MaHang As String, I As Long, J As Long, K As Long, R As Long
    sArr = Range("a4:a22").Value ' input
    R = UBound(sArr)
    ReDim dArr(1 To R * 100, 1 To 4)
With CreateObject("Scripting.Dictionary")
For I = 2 To R
    Tmp = Split(sArr(I, 1), ";")
    For J = 0 To UBound(Tmp)
        If Len(Tmp(J)) Then
            Tem = Split(Tmp(J), "*"): MaHang = UCase(Tem(0))
            If Not .Exists(MaHang) Then
                K = K + 1: .Add MaHang, K
                dArr(K, 1) = MaHang
            End If
            R = .Item(MaHang)
            dArr(R, 2) = dArr(R, 2) + Val(Tem(1))
            dArr(R, 3) = dArr(R, 3) + Val(Tem(2))
            dArr(R, 4) = dArr(R, 4) + Val(Tem(3))
        End If
    Next J
Next I
End With
Range("N5:Q5").Resize(K) = dArr ' output
End Sub

 

[HieuCD]

sửa code của bạn lại

Sub Tach()
Dim Darr(), Arr(1 To 1000, 1 To 4), Tmp, Tem
Dim i As Long, n As Byte, k As Long, j As Byte
Darr = Range("A5:A" & Range("A65500").End(xlUp).Row).Value
For i = 1 To UBound(Darr)
  Tmp = Split(Darr(i, 1), ";")
  On Error Resume Next
  For n = 0 To UBound(Tmp)
    If Tmp(n) <> "" Then
      Tem = Split(Tmp(n), "*")
      k = k + 1
      For j = 0 To 3
          Arr(k, j + 1) = Tem(j)
      Next j
    End If
  Next n
Next i
Range("I5").Resize(k, 4) = Arr
End Sub

 

[minhtuan55]

Anh ơi Code chạy sai rồi anh. Dòng cuối cùng code nó tạo ra Nước suối quá nhiều hàng luôn. Em gửi Ảnh và File a xem lại giúp em

sửa code của bạn lại

Sub Tach()
Dim Darr(), Arr(1 To 1000, 1 To 4), Tmp, Tem
Dim i As Long, n As Byte, k As Long, j As Byte
Darr = Range("A5:A" & Range("A65500").End(xlUp).Row).Value
For i = 1 To UBound(Darr)
  Tmp = Split(Darr(i, 1), ";")
  On Error Resume Next
  For n = 0 To UBound(Tmp)
    If Tmp(n) <> "" Then
      Tem = Split(Tmp(n), "*")
      k = k + 1
      For j = 0 To 3
          Arr(k, j + 1) = Tem(j)
      Next j
    End If
  Next n
Next i
Range("I5").Resize(k, 4) = Arr
End Sub

 

[HieuCD]

Anh ơi Code chạy sai rồi anh. Dòng cuối cùng code nó tạo ra Nước suối quá nhiều hàng luôn. Em gửi Ảnh và File a xem lại giúp em

trong file, bạn sửa lại code bị sai, nên chạy ra kết quả sai
bạn xóa code cũ và copy code của mình gởi dán vào và chạy lại xem sao

 

[minhtuan55]

trong file, bạn sửa lại code bị sai, nên chạy ra kết quả sai
bạn xóa code cũ và copy code của mình gởi dán vào và chạy lại xem sao

Dạ Anh ơi em muốn cái địa chỉ cần tách là cố định Darr = Range("A5:A22") nếu ô nào trống thì anh đừng cho xuất ra , chứ anh làm kiểu Darr = Range("A5:A" & Range("A65500").End(xlUp).Row).Value
Thì em thấy không ổn. Vì đây là File mẫu nên dữ liệu bên dưới vùng A5:A22 không có, chứ File thực tế của em dữ liệu bên dưới nó có dữ liệu nữa. mong anh sữa lại giúp

 

[HieuCD]

Dạ Anh ơi em muốn cái địa chỉ cần tách là cố định Darr = Range("A5:A22") nếu ô nào trống thì anh đừng cho xuất ra , chứ anh làm kiểu Darr = Range("A5:A" & Range("A65500").End(xlUp).Row).Value
Thì em thấy không ổn. Vì đây là File mẫu nên dữ liệu bên dưới vùng A5:A22 không có, chứ File thực tế của em dữ liệu bên dưới nó có dữ liệu nữa. mong anh sữa lại giúp

bạn chạy thử code

Sub Tach()
Dim Darr(), Arr(1 To 1000, 1 To 4), Tmp, Tem
Dim i As Long, n As Byte, k As Long, j As Byte
Darr = Range("A5:A22").Value
On Error Resume Next
For i = 1 To UBound(Darr)
  If Darr(i, 1) <> "" Then
    Tmp = Split(Darr(i, 1), ";")
    For n = 0 To UBound(Tmp)
      If Tmp(n) <> "" Then
        Tem = Split(Tmp(n), "*")
        k = k + 1
        For j = 0 To 3
          Arr(k, j + 1) = Tem(j)
        Next j
      End If
    Next n
  End If
Next i
Range("I5").Resize(k, 4) = Arr
End Sub

 

[minhtuan55]

Không còn gì để nói, quá chính xác, phải nói là đúng ý em hoàn toàn 100% . Em chân thành cảm ơn, Anh có thể cho em số điện thoại để em mời đi nhậu 1 chầu mới được ( em ở Sài gòn )

bạn chạy thử code

Sub Tach()
Dim Darr(), Arr(1 To 1000, 1 To 4), Tmp, Tem
Dim i As Long, n As Byte, k As Long, j As Byte
Darr = Range("A5:A22").Value
On Error Resume Next
For i = 1 To UBound(Darr)
  If Darr(i, 1) <> "" Then
    Tmp = Split(Darr(i, 1), ";")
    For n = 0 To UBound(Tmp)
      If Tmp(n) <> "" Then
        Tem = Split(Tmp(n), "*")
        k = k + 1
        For j = 0 To 3
          Arr(k, j + 1) = Tem(j)
        Next j
      End If
    Next n
  End If
Next i
Range("I5").Resize(k, 4) = Arr
End Sub