Lặp và ghép dữ liệu theo từng cell tại từng dòng

hadoan-pap · 16/12/21

Em chào mọi người ạ.

Dạ, em có dữ liệu đầu vào là Sheet1, số lượng dòng rất nhiều và không cố định ạ.

Em muốn kiếm tra chạy từng dòng để kiểm tra và ra được kết quả trả về ô A2 như Sheet2 ạ.

Em xin cảm ơn rất nhiều!

befaint · 16/12/21

Bảng dữ liệu gì mà kỳ quặc thế.

Viết code bao nhiêu rồi cũng không bằng nắm cái căn bản: Bảng dữ liệu PHẢI đúng chuẩn.

Mình điền đầy đủ giá trị vào cột B đi, rồi muốn làm gì thì làm.

hadoan-pap · 16/12/21

befaint đã viết:
Bảng dữ liệu gì mà kỳ quặc thế.

Viết code bao nhiêu rồi cũng không bằng nắm cái căn bản: Bảng dữ liệu PHẢI đúng chuẩn.

Mình điền đầy đủ giá trị vào cột B đi, rồi muốn làm gì thì làm.

View attachment 270379

Dạ, đầu ra dữ liệu nó như vậy anh ạ. Các Item ở cột A thì cái có dữ liệu ở cột B và cái thì không có anh ạ.

Nhưng sau đó phải ghép để trả ra dữ liệu như ô A2 ở sheet2 ạ.

HieuCD · 16/12/21

hadoan-pap đã viết:
Em chào mọi người ạ.

Dạ, em có dữ liệu đầu vào là Sheet1, số lượng dòng rất nhiều và không cố định ạ.

Em muốn kiếm tra chạy từng dòng để kiểm tra và ra được kết quả trả về ô A2 như Sheet2 ạ.

Em xin cảm ơn rất nhiều!

Chạy code . . .

Mã:

Sub ABC()
  Dim sArr(), arr(), res$, tmp$, srow&, i&, k&
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:B" & i).Value
  End With
  srow = UBound(sArr)
 
  For i = 1 To srow
    If sArr(i, 2) = Empty Then
      If tmp = Empty Then tmp = "[" & sArr(i, 1)
    Else
      k = k + 1
      ReDim Preserve arr(1 To k)
      If tmp = Empty Then
        arr(k) = "[" & sArr(i, 1) & "] : " & sArr(i, 2)
      Else
        arr(k) = tmp & " - " & sArr(i, 1) & "] : " & sArr(i, 2)
        tmp = Empty
      End If
    End If
  Next i
  Sheets("Sheet2").Range("B2") = Join(arr, Chr(10))
End Sub

hadoan-pap · 17/12/21

HieuCD đã viết:

Chạy code . . .

Mã:

Sub ABC()
  Dim sArr(), arr(), res$, tmp$, srow&, i&, k&
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:B" & i).Value
  End With
  srow = UBound(sArr)
 
  For i = 1 To srow
    If sArr(i, 2) = Empty Then
      If tmp = Empty Then tmp = "[" & sArr(i, 1)
    Else
      k = k + 1
      ReDim Preserve arr(1 To k)
      If tmp = Empty Then
        arr(k) = "[" & sArr(i, 1) & "] : " & sArr(i, 2)
      Else
        arr(k) = tmp & " - " & sArr(i, 1) & "] : " & sArr(i, 2)
        tmp = Empty
      End If
    End If
  Next i
  Sheets("Sheet2").Range("B2") = Join(arr, Chr(10))
End Sub

Em xin cảm ơn nhiều ạ ! ^^

hadoan-pap · 18/12/21

HieuCD đã viết:

Chạy code . . .

Mã:

Sub ABC()
  Dim sArr(), arr(), res$, tmp$, srow&, i&, k&
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:B" & i).Value
  End With
  srow = UBound(sArr)
 
  For i = 1 To srow
    If sArr(i, 2) = Empty Then
      If tmp = Empty Then tmp = "[" & sArr(i, 1)
    Else
      k = k + 1
      ReDim Preserve arr(1 To k)
      If tmp = Empty Then
        arr(k) = "[" & sArr(i, 1) & "] : " & sArr(i, 2)
      Else
        arr(k) = tmp & " - " & sArr(i, 1) & "] : " & sArr(i, 2)
        tmp = Empty
      End If
    End If
  Next i
  Sheets("Sheet2").Range("B2") = Join(arr, Chr(10))
End Sub

Gửi anh.

Anh ơi sao trong file em có đổi sang kiểu dữ liệu khác thì nó lại chạy không ra kết quả như cũ anh nhỉ ?

Em kiểm tra nhưng chưa biết nguyên nhân tại sao ạ.

Anh vui lòng xem giúp em với ạ.

Em cảm ơn anh!

HieuCD · 18/12/21

hadoan-pap đã viết:
Gửi anh.

Anh ơi sao trong file em có đổi sang kiểu dữ liệu khác thì nó lại chạy không ra kết quả như cũ anh nhỉ ?

Em kiểm tra nhưng chưa biết nguyên nhân tại sao ạ.

Anh vui lòng xem giúp em với ạ.

Em cảm ơn anh!

Dữ liệu quá tầm bậy! cột B nhìn giống rổng nhưng không phải

Mã:

Sub Button1_Click()
  Dim sArr(), arr(), res$, tmp$, srow&, i&, k&
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:B" & i).Value
  End With
  srow = UBound(sArr)
  For i = 1 To srow
    If Replace(sArr(i, 2), " ", "") = Empty Then
      If tmp = Empty Then tmp = "[" & sArr(i, 1)
    Else
      k = k + 1
      ReDim Preserve arr(1 To k)
      If tmp = Empty Then
        arr(k) = "[" & sArr(i, 1) & "] : " & sArr(i, 2)
      Else
        arr(k) = tmp & " - " & sArr(i, 1) & "] : " & sArr(i, 2)
        tmp = Empty
      End If
    End If
  Next i
  Sheets("Sheet2").Range("A2") = Join(arr, Chr(10))
End Sub

hadoan-pap · 18/12/21

HieuCD đã viết:

Dữ liệu quá tầm bậy! cột B nhìn giống rổng nhưng không phải

Mã:

Sub Button1_Click()
  Dim sArr(), arr(), res$, tmp$, srow&, i&, k&
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:B" & i).Value
  End With
  srow = UBound(sArr)
  For i = 1 To srow
    If Replace(sArr(i, 2), " ", "") = Empty Then
      If tmp = Empty Then tmp = "[" & sArr(i, 1)
    Else
      k = k + 1
      ReDim Preserve arr(1 To k)
      If tmp = Empty Then
        arr(k) = "[" & sArr(i, 1) & "] : " & sArr(i, 2)
      Else
        arr(k) = tmp & " - " & sArr(i, 1) & "] : " & sArr(i, 2)
        tmp = Empty
      End If
    End If
  Next i
  Sheets("Sheet2").Range("A2") = Join(arr, Chr(10))
End Sub

Dạ e cảm ơn anh nhiều ạ.

Em cũng ko để ý dữ liệu lại có dấu cách như vậy ạ ^^

hadoan-pap · 27/12/21

HieuCD đã viết:

Dữ liệu quá tầm bậy! cột B nhìn giống rổng nhưng không phải

Mã:

Sub Button1_Click()
  Dim sArr(), arr(), res$, tmp$, srow&, i&, k&
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:B" & i).Value
  End With
  srow = UBound(sArr)
  For i = 1 To srow
    If Replace(sArr(i, 2), " ", "") = Empty Then
      If tmp = Empty Then tmp = "[" & sArr(i, 1)
    Else
      k = k + 1
      ReDim Preserve arr(1 To k)
      If tmp = Empty Then
        arr(k) = "[" & sArr(i, 1) & "] : " & sArr(i, 2)
      Else
        arr(k) = tmp & " - " & sArr(i, 1) & "] : " & sArr(i, 2)
        tmp = Empty
      End If
    End If
  Next i
  Sheets("Sheet2").Range("A2") = Join(arr, Chr(10))
End Sub

Gửi anh!

Dạ e dùng code này để chạy trong vòng lặp, e đã dùng 2 lệnh như bên dưới để xóa arr tại cuối lệnh loop. Nhưng hình như nó vẫn chưa đúng vì khi ghi dữ liệu lần mới thì nó vẫn còn 1 dòng dữ liệu cũ bị dính vào ạ.

Nguyên nhân này là do đâu vậy anh nhỉ?

Em cảm ơn anh!

Erase arr
Erase sArr

[12/31/2021 - 12/27/2021] : 27.5
[12/28/2021 - 12/31/2021] : 25.5

hadoan-pap · 27/12/21

HieuCD đã viết:

Dữ liệu quá tầm bậy! cột B nhìn giống rổng nhưng không phải

Mã:

Sub Button1_Click()
  Dim sArr(), arr(), res$, tmp$, srow&, i&, k&
  With Sheets("Sheet1")
    i = .Range("A" & Rows.Count).End(xlUp).Row
    If i < 2 Then MsgBox ("Khong co du lieu"): Exit Sub
    sArr = .Range("A2:B" & i).Value
  End With
  srow = UBound(sArr)
  For i = 1 To srow
    If Replace(sArr(i, 2), " ", "") = Empty Then
      If tmp = Empty Then tmp = "[" & sArr(i, 1)
    Else
      k = k + 1
      ReDim Preserve arr(1 To k)
      If tmp = Empty Then
        arr(k) = "[" & sArr(i, 1) & "] : " & sArr(i, 2)
      Else
        arr(k) = tmp & " - " & sArr(i, 1) & "] : " & sArr(i, 2)
        tmp = Empty
      End If
    End If
  Next i
  Sheets("Sheet2").Range("A2") = Join(arr, Chr(10))
End Sub

Dạ em đã sửa được rồi ạ.

Em thiếu cái khai báo tmp = Empty vào cuối vòng loop ạ

Lặp và ghép dữ liệu theo từng cell tại từng dòng

hadoan-pap

Thành viên tiêu biểu

File đính kèm

befaint

|||||||||||||

hadoan-pap

Thành viên tiêu biểu

HieuCD

Chuyên gia GPE

hadoan-pap

Thành viên tiêu biểu

hadoan-pap

Thành viên tiêu biểu

File đính kèm

HieuCD

Chuyên gia GPE

hadoan-pap

Thành viên tiêu biểu

hadoan-pap

Thành viên tiêu biểu

hadoan-pap

Thành viên tiêu biểu

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

Facebook

Group

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