Chuyển dữ liệu sắp xếp theo hàng ngang về dạng cột dọc

[hoangtuaotrang_hp_vn]

Em muốn chuyển và tập hợp dữ liệu ở tất cả các sheet của file "Du lieu" về chung 1 sheet của file "Mong muon" (theo cấu trúc của file "Mong muon" luôn ạ ,

Em thử làm thủ công thì thấy lâu quá, mong anh/chị giúp giải pháp cho nhanh hơn với ạ

Em chân thành cảm ơn

 

[snow25]

Em muốn chuyển và tập hợp dữ liệu ở tất cả các sheet của file "Du lieu" về chung 1 sheet của file "Mong muon" (theo cấu trúc của file "Mong muon" luôn ạ ,

Em thử làm thủ công thì thấy lâu quá, mong anh/chị giúp giải pháp cho nhanh hơn với ạ

Em chân thành cảm ơn

View attachment 208311

Đây bạn xem.
Dữ liệu được chuyển về Sheet2

 

[hoangtuaotrang_hp_vn]

Đây bạn xem.
Dữ liệu được chuyển về Sheet2

anh ơi, mới có dữ liệu SL1 ạ? em muốn khi hết dữ liệu của sheet SL1 thì nối tiếp dữ liệu của SL2, SL3.... cho đến hết ạ,

Em cảm ơn anh

 

[snow25]

anh ơi, mới có dữ liệu SL1 ạ? em muốn khi hết dữ liệu của sheet SL1 thì nối tiếp dữ liệu của SL2, SL3.... cho đến hết ạ,

Em cảm ơn anh

Vậy tối nhé giờ về nhà đã bạn.

 

[hoangtuaotrang_hp_vn]

Vậy tối nhé giờ về nhà đã bạn.

vâng anh cố gắng thu xếp giúp em với nhé, ngoài file này em còn phải làm tương tự cho khá nhiều file khác nữa

 

[snow25]

anh ơi, mới có dữ liệu SL1 ạ? em muốn khi hết dữ liệu của sheet SL1 thì nối tiếp dữ liệu của SL2, SL3.... cho đến hết ạ,

Em cảm ơn anh

Đây bạn xem nhé.

 

[hoangtuaotrang_hp_vn]

Em chào các anh/chị,

em lại gặp phải vấn đề với dạng bài này,

Em có sheet 'Du lieu' muốn chuyển dạng hàng ngang thành cột dọc như sheet 'Mong Muon', chi tiết em mô tả trong file,

mong anh/chị giúp em với ạ,

Em chân thành cảm ơn anh/chị

 

[snow25]

Em chào các anh/chị,

em lại gặp phải vấn đề với dạng bài này,

Em có sheet 'Du lieu' muốn chuyển dạng hàng ngang thành cột dọc như sheet 'Mong Muon', chi tiết em mô tả trong file,

mong anh/chị giúp em với ạ,

Em chân thành cảm ơn anh/chị

Bạn xem code nhé.Những dòng không có lỗi nào sẽ không cho vào đấy.

Sub chuyencot()
    Dim arr, arr1, i As Long, j As Long, lr As Long, lc As Integer, a As Long, T
    With Sheets("du lieu")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         lc = .Cells(1, Columns.Count).End(xlToLeft).Column
         arr = .Range("A1").Resize(lr, lc).Value
         ReDim arr1(1 To UBound(arr, 1) * 20, 1 To UBound(arr, 2))
         For i = 1 To UBound(arr, 2)
             arr1(1, i) = arr(1, i)
         Next i
         For i = 13 To UBound(arr, 2)
             T = Split("(" & arr(1, i), "(")
            If UBound(T) > 1 Then arr(1, i) = Left(T(UBound(T)), Len(T(UBound(T))) - 1) Else arr(i, 1) = T(1)
         Next i
         a = 1
         For i = 2 To UBound(arr, 1)
             a = a + 1
             For j = 1 To 10
                 arr1(a, j) = arr(i, j)
             Next j
             For j = 13 To UBound(arr, 2)
                 arr1(a, j) = arr(i, j)
             Next j
             For j = 13 To UBound(arr, 2)
                 If Len(arr(i, j)) > 0 Then
                    arr1(a, 11) = arr(1, j)
                    arr1(a, 12) = arr(i, j)
                    a = a + 1
                 End If
             Next j
             a = a - 1
        Next i
    End With
    With Sheets("mong muon")
         .Cells.ClearContents
         If a Then .Range("A1").Resize(a, lc).Value = arr1
    End With
End Sub

 

[hoangtuaotrang_hp_vn]

@snow25 : anh ơi, anh giúp em thêm chút được không ạ, em muốn copy thông tin giống nhau xuống các dòng dưới (riêng số lượng nhập thì không copy xuống vì sẽ bị trùng lặp khi dùng hàm thống kê ạ)

 

[snow25]

@snow25 : anh ơi, anh giúp em thêm chút được không ạ, em muốn copy thông tin giống nhau xuống các dòng dưới (riêng số lượng nhập thì không copy xuống vì sẽ bị trùng lặp khi dùng hàm thống kê ạ) View attachment 213459

Bạn xem code.

Sub chuyencot()
    Dim arr, arr1, i As Long, j As Long, lr As Long, lc As Integer, a As Long, T, k As Integer
    With Sheets("du lieu")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         lc = .Cells(1, Columns.Count).End(xlToLeft).Column
         arr = .Range("A1").Resize(lr, lc).Value
         ReDim arr1(1 To UBound(arr, 1) * 20, 1 To UBound(arr, 2))
         For i = 1 To UBound(arr, 2)
             arr1(1, i) = arr(1, i)
         Next i
         For i = 13 To UBound(arr, 2)
             T = Split("(" & arr(1, i), "(")
            If UBound(T) > 1 Then arr(1, i) = Left(T(UBound(T)), Len(T(UBound(T))) - 1) Else arr(i, 1) = T(1)
         Next i
         a = 1
         For i = 2 To UBound(arr, 1)
             a = a + 1
             arr1(a, 10) = arr(i, 10)
             For j = 13 To UBound(arr, 2)
                 arr1(a, j) = arr(i, j)
             Next j
             For j = 13 To UBound(arr, 2)
                 If Len(arr(i, j)) > 0 Then
                    For k = 1 To 9
                       arr1(a, k) = arr(i, k)
                    Next k
                    arr1(a, 11) = arr(1, j)
                    arr1(a, 12) = arr(i, j)
                    a = a + 1
                 End If
             Next j
             a = a - 1
        Next i
    End With
    With Sheets("mong muon")
         .Cells.ClearContents
         If a Then .Range("A1").Resize(a, lc).Value = arr1
    End With
End Sub