Copy dữ liệu kết hợp dòng và cột bằng VBA

[tranphuson]

Vui lòng giúp mình copy dữ liệu bằng VBA

Mỗi Cột C1, kết hợp với B2 đến hết B440. Cột C1 Sheet "DATA" sẽ được copy dọc qua Sheet "COPY"

Tổng cộng có 74 Cột bên Sheet "DATA" nhân với 439 dòng Cột B Sheet "DATA" = 32,486 dòng

Xin cảm ơn

 

[♫ђöล♥ßล†♥†µ♫]

Vui lòng giúp mình copy dữ liệu bằng VBA

Mỗi Cột C1, kết hợp với B2 đến hết B440. Cột C1 Sheet "DATA" sẽ được copy dọc qua Sheet "COPY"

Tổng cộng có 74 Cột bên Sheet "DATA" nhân với 439 dòng Cột B Sheet "DATA" = 32,486 dòng

Xin cảm ơn

Bạn thử cái này

Sub CopyData()
    Dim sArr, dArr, C As Long, R As Long, I As Long, J As Long, K As Long, Er As Long
With Sheet1
    C = .Range("B1").End(xlToRight).Column
    If C > 2 Then
        sArr = .Range("B1", .Range("B" & Rows.Count).End(xlUp)).Resize(, C - 1).Value
       R = (UBound(sArr) - 1) * (C - 2)
        If R < Rows.Count - 1 Then
            ReDim dArr(1 To R, 1 To 3)
            For J = 2 To UBound(sArr, 2)
                For I = 2 To UBound(sArr, 1)
                    K = K + 1: dArr(K, 1) = K
                    dArr(K, 2) = sArr(1, J): dArr(K, 3) = sArr(I, 1)
                Next I
            Next J
            With Sheet2
                Er = .Range("E" & Rows.Count).End(xlUp).Row
                If Er > 1 Then .Range("E2:G" & Er).ClearContents
                .Range("E2").Resize(K, 3) = dArr
            End With
        Else
            MsgBox "So dong nhieu hon so dong bang tinh"
        End If
    Else
        MsgBox "Nothing"
    End If
End With
End Sub

 

[HieuCD]

Bạn thử cái này

Sub CopyData()
    Dim sArr, dArr, C As Long, R As Long, I As Long, J As Long, K As Long, Er As Long
With Sheet1
    C = .Range("B1").End(xlToRight).Column
    If C > 2 Then
        sArr = .Range("B1", .Range("B" & Rows.Count).End(xlUp)).Resize(, C - 1).Value
       R = (UBound(sArr) - 1) * (C - 2)
        If R < Rows.Count - 1 Then
            ReDim dArr(1 To R, 1 To 3)
            For J = 2 To UBound(sArr, 2)
                For I = 2 To UBound(sArr, 1)
                    K = K + 1: dArr(K, 1) = K
                    dArr(K, 2) = sArr(1, J): dArr(K, 3) = sArr(I, 1)
                Next I
            Next J
            With Sheet2
                Er = .Range("E" & Rows.Count).End(xlUp).Row
                If Er > 1 Then .Range("E2:G" & Er).ClearContents
                .Range("E2").Resize(K, 3) = dArr
            End With
        Else
            MsgBox "So dong nhieu hon so dong bang tinh"
        End If
    Else
        MsgBox "Nothing"
    End If
End With
End Sub

Dài dòng quá, Chạy lẹ

 

[tranphuson]

Bạn thử cái này

Sub CopyData()
    Dim sArr, dArr, C As Long, R As Long, I As Long, J As Long, K As Long, Er As Long
With Sheet1
    C = .Range("B1").End(xlToRight).Column
    If C > 2 Then
        sArr = .Range("B1", .Range("B" & Rows.Count).End(xlUp)).Resize(, C - 1).Value
       R = (UBound(sArr) - 1) * (C - 2)
        If R < Rows.Count - 1 Then
            ReDim dArr(1 To R, 1 To 3)
            For J = 2 To UBound(sArr, 2)
                For I = 2 To UBound(sArr, 1)
                    K = K + 1: dArr(K, 1) = K
                    dArr(K, 2) = sArr(1, J): dArr(K, 3) = sArr(I, 1)
                Next I
            Next J
            With Sheet2
                Er = .Range("E" & Rows.Count).End(xlUp).Row
                If Er > 1 Then .Range("E2:G" & Er).ClearContents
                .Range("E2").Resize(K, 3) = dArr
            End With
        Else
            MsgBox "So dong nhieu hon so dong bang tinh"
        End If
    Else
        MsgBox "Nothing"
    End If
End With
End Sub

Xin cảm ơn đã làm được

 

[ndu96081631]

Dạng bài này không cần code hay công thức gì ráo, cứ dùng UnPivotTable ra kết quả trong 30s

 

[tranphuson]

Dạng bài này không cần code hay công thức gì ráo, cứ dùng UnPivotTable ra kết quả trong 30s

Vậy anh có thể chỉ mình thêm cách sử dụng này được chứ!

Cảm ơn Anh

 

[ndu96081631]

Vậy anh có thể chỉ mình thêm cách sử dụng này được chứ!

Cảm ơn Anh

Thật ra với từ khóa UnPivotTable, bạn đã có thể tìm được các thông tin mình cần rồi.

Lưu ý: Sau khi PivotTable được tạo sẽ có công đoạn double click vào giao điểm của 2 GrandTotal dòng và cột (trong video là khoảng giây thứ 40), lập tức 1 sheet khác được tạo với dữ liệu là cái bạn cần
----------------------------------
Nhân tiện cảnh báo: File của bạn bị dính quá nhiều styles rác, đồng thời style normal cũng bị luôn

 

[tranphuson]

Thật ra với từ khóa UnPivotTable, bạn đã có thể tìm được các thông tin mình cần rồi.

Lưu ý: Sau khi PivotTable được tạo sẽ có công đoạn double click vào giao điểm của 2 GrandTotal dòng và cột (trong video là khoảng giây thứ 40), lập tức 1 sheet khác được tạo với dữ liệu là cái bạn cần
----------------------------------
Nhân tiện cảnh báo: File của bạn bị dính quá nhiều styles rác, đồng thời style normal cũng bị luôn

Cảm ơn Anh đã hướng dẫn thêm 1 cách và chỉ ra các lỗi trong file này