Nhờ giúp đỡ code tổng hợp dữ liệu

[Eric.Shen]

Chào các bác!
Em đang có một bảng dữ liệu cần tổng hợp lại để làm báo cáo,
Nhờ các bác viết giúp em một code để tổng hợp lại ạ
Chi tiết thông tin như tệp em đính kèm ạ
Em cần tổng hợp từ bảng A thành báo cáo như bảng B
Em cảm ơn ạ!

 

[bebo021999]

Dùng tạm code này nhé:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, rng, res(1 To 100000, 1 To 3)
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A3:I" & lr).Value
For j = 3 To UBound(rng, 2) Step 2
    For i = 2 To UBound(rng)
        If rng(i, j) <> "" And IsNumeric(rng(i, j)) Then
            k = k + 1
            res(k, 1) = rng(1, j - 1)
            res(k, 2) = rng(i, 1)
            res(k, 3) = rng(i, j)
        End If
    Next
Next
Range("M4:O10000").ClearContents
Range("M4").Resize(k, 3).Value = res
End Sub

 

[xì tin]

Chào các bác!
Em đang có một bảng dữ liệu cần tổng hợp lại để làm báo cáo,
Nhờ các bác viết giúp em một code để tổng hợp lại ạ
Chi tiết thông tin như tệp em đính kèm ạ
Em cần tổng hợp từ bảng A thành báo cáo như bảng B
Em cảm ơn ạ!

Thử code sau nhen

Sub Test()
    Dim i As Integer, strSql As String
    For i = 3 To 9 Step 2
        strSql = strSql & " Union All select '" & Sheet1.Cells(3, i - 1) & "', F1,F" & i & " From [Sheet1$A4:I] Where F" & i & " Is not null"
    Next
    With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
        Sheet1.Range("M16").CopyFromRecordset .Execute(Right(strSql, Len(strSql) - 10))
    End With
End Sub

 

[Eric.Shen]

Dùng tạm code này nhé:

Option Explicit
Sub test()
Dim lr&, i&, j&, k&, rng, res(1 To 100000, 1 To 3)
lr = Cells(Rows.Count, "A").End(xlUp).Row
rng = Range("A3:I" & lr).Value
For j = 3 To UBound(rng, 2) Step 2
    For i = 2 To UBound(rng)
        If rng(i, j) <> "" And IsNumeric(rng(i, j)) Then
            k = k + 1
            res(k, 1) = rng(1, j - 1)
            res(k, 2) = rng(i, 1)
            res(k, 3) = rng(i, j)
        End If
    Next
Next
Range("M4:O10000").ClearContents
Range("M4").Resize(k, 3).Value = res
End Sub

Kết quả đúng rồi ạ, em cảm ơn bác nhiều ạ

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

Thử code sau nhen

Sub Test()
    Dim i As Integer, strSql As String
    For i = 3 To 9 Step 2
        strSql = strSql & " Union All select '" & Sheet1.Cells(3, i - 1) & "', F1,F" & i & " From [Sheet1$A4:I] Where F" & i & " Is not null"
    Next
    With CreateObject("ADODB.Connection")
        .Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & ThisWorkbook.FullName & ";Extended Properties=""Excel 12.0 Xml;HDR=No"""
        Sheet1.Range("M16").CopyFromRecordset .Execute(Right(strSql, Len(strSql) - 10))
    End With
End Sub

Máy em dùng bản office 2016 mà không hiểu sao không chạy được các code ADO này nên em chưa thử được
Nhưng em cũng cảm ơn bác rất nhiều vì đã giúp đỡ em ạ