Hỏi cách gom dữ liệu trong excel (1 người xem)

[dantaichinhketoan]

Chào mọi người. Mọi người cho mình hỏi có cách nào gom dữ liệu lại thành 1 vùng ( bỏ qua các ô trống) trong excel không? Ví dụ trong file của mình. Sheet " Du lieu" các số nằm rải rác. Mình muốn tập trung dữ liệu về 1 vùng như sheet " bao cao". Mong mọi người chỉ giúp mình.
Xin cảm ơn

 

[BuiQuangThuan]

Chào mọi người. Mọi người cho mình hỏi có cách nào gom dữ liệu lại thành 1 vùng ( bỏ qua các ô trống) trong excel không? Ví dụ trong file của mình. Sheet " Du lieu" các số nằm rải rác. Mình muốn tập trung dữ liệu về 1 vùng như sheet " bao cao". Mong mọi người chỉ giúp mình.
Xin cảm ơn

Kết quả demo của bạn hình như sai sao á. Thử code này coi

Sub ABC()
    Dim sArr(), Res(), i&, j&, tmp&, K&
    With Sheets("Du lieu")
        sArr = .Range("A1:L" & .Range("A" & Rows.Count).End(3).Row).Value
    End With
    ReDim Res(1 To UBound(sArr), 1 To 1000)
    For i = 1 To UBound(sArr)
        Res(i, 1) = sArr(i, 1)
        For j = 2 To UBound(sArr, 2)
            If sArr(i, j) <> Empty Then
                K = K + 1
                Res(i, K + 1) = sArr(i, j)
            End If
            If tmp > K Then tmp = tmp Else tmp = K
        Next:                   K = 0
    Next
    With Sheets("Bao cao")
        .Range("A13").Resize(UBound(sArr), tmp + 1).Value = Res
    End With
End Sub

 

[snow25]

Chào mọi người. Mọi người cho mình hỏi có cách nào gom dữ liệu lại thành 1 vùng ( bỏ qua các ô trống) trong excel không? Ví dụ trong file của mình. Sheet " Du lieu" các số nằm rải rác. Mình muốn tập trung dữ liệu về 1 vùng như sheet " bao cao". Mong mọi người chỉ giúp mình.
Xin cảm ơn

Bạn thử code.

Sub abc()
    Dim arr, kq, i As Long, j As Integer, b As Long, lr As Long
    With Sheets("du lieu")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A1:L" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 12)
        For i = 1 To UBound(arr)
            kq(i, 1) = arr(i, 1)
            b = 1
            For j = 2 To 12
                If Len(arr(i, j)) > 0 Then
                   b = b + 1
                   kq(i, b) = arr(i, j)
                End If
             Next j
        Next i
  End With
  With Sheets("bao cao")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1:L" & lr).ClearContents
        .Range("A1:L1").Resize(i - 1).Value = kq
  End With
End Sub

 

[dantaichinhketoan]

Kết quả demo của bạn hình như sai sao á. Thử code này coi

Sub ABC()
    Dim sArr(), Res(), i&, j&, tmp&, K&
    With Sheets("Du lieu")
        sArr = .Range("A1:L" & .Range("A" & Rows.Count).End(3).Row).Value
    End With
    ReDim Res(1 To UBound(sArr), 1 To 1000)
    For i = 1 To UBound(sArr)
        Res(i, 1) = sArr(i, 1)
        For j = 2 To UBound(sArr, 2)
            If sArr(i, j) <> Empty Then
                K = K + 1
                Res(i, K + 1) = sArr(i, j)
            End If
            If tmp > K Then tmp = tmp Else tmp = K
        Next:                   K = 0
    Next
    With Sheets("Bao cao")
        .Range("A13").Resize(UBound(sArr), tmp + 1).Value = Res
    End With
End Sub

cảm ơn bác nhiều nhé

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

Bạn thử code.

Sub abc()
    Dim arr, kq, i As Long, j As Integer, b As Long, lr As Long
    With Sheets("du lieu")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A1:L" & lr).Value
        ReDim kq(1 To UBound(arr), 1 To 12)
        For i = 1 To UBound(arr)
            kq(i, 1) = arr(i, 1)
            b = 1
            For j = 2 To 12
                If Len(arr(i, j)) > 0 Then
                   b = b + 1
                   kq(i, b) = arr(i, j)
                End If
             Next j
        Next i
  End With
  With Sheets("bao cao")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        .Range("A1:L" & lr).ClearContents
        .Range("A1:L1").Resize(i - 1).Value = kq
  End With
End Sub

cảm ơn bác nhiều nhé