Nhờ tách các bảng dữ liệu ngang trong sheet thành một bảng dữ liệu dọc

[dungcpt]

Chào cả nhà, tình hình là mình có 1 file excel (như file gửi kèm ở đây)
Vì là file xuất ra từ ứng dụng khác để in ấn nên nó có định dạng sẵn như Sheet1 (5 bảng 1 trang).

Bây giờ mình muốn: Copy các bảng trong Sheet1 sang Sheet2 lần lượt, sau đó tự động đánh thêm số liệu như yêu cầu mình đã ghi trong Sheet2, sau khi copy xong thì xóa các dữ liệu thừa và copy lần nữa sang Sheet3.

Thanks mọi người.

 

[huuthang_bd]

Bài vi phạm nội quy vì tiêu đề chung chung.
Mod đi qua vui lòng nhắc nhở và sửa lại tiêu đề giùm chứ đừng xóa.

Sub TablesToCol()
Dim FindCll As Range, FindCllAdd As String
On Error Resume Next
Application.ScreenUpdating = False
With Sheet1
    Set FindCll = .Columns("A:C").Find(What:="~*TÚI", After:=.Cells(1, 1), LookAt:=xlPart, SearchDirection:=xlNext)
End With
If FindCll Is Nothing Then GoTo ExitSub
FindCllAdd = FindCll.Address
Sheet2.UsedRange.Clear
FindCll.Offset(1).Resize(1, 3).Copy Sheet2.Cells(1, 1)
Sheet2.Cells(1, 4).Value = "M" & ChrW(227) & " t" & ChrW(250) & "i"
Do
    CopyTable FindCll.CurrentRegion
    Set FindCll = Sheet1.Columns("A:C").FindNext(FindCll)
Loop Until FindCll.Address = FindCllAdd
ExitSub:
Application.ScreenUpdating = True
End Sub

Private Sub CopyTable(Rng As Range)
Dim i As Long, Rs As Long
Rs = Rng.Rows.Count
For i = 1 To Rng.Columns.Count Step 3
    Sheet1.Range(Rng.Cells(3, i), Rng.Cells(Rs, i + 2)).Copy Sheet2.Cells(&H100000, 1).End(xlUp).Offset(1)
    Sheet2.Range(Sheet2.Cells(&H100000, 1).End(xlUp).Offset(, 3), Sheet2.Cells(&H100000, 4).End(xlUp).Offset(1)).Value = Mid(Rng.Cells(1, i), 6)
Next
End Sub

 

[Lê Duy Thương]

Chào cả nhà, tình hình là mình có 1 file excel (như file gửi kèm ở đây)
Vì là file xuất ra từ ứng dụng khác để in ấn nên nó có định dạng sẵn như Sheet1 (5 bảng 1 trang).

Bây giờ mình muốn: Copy các bảng trong Sheet1 sang Sheet2 lần lượt, sau đó tự động đánh thêm số liệu như yêu cầu mình đã ghi trong Sheet2, sau khi copy xong thì xóa các dữ liệu thừa và copy lần nữa sang Sheet3.

Thanks mọi người.

Nếu chỉ cần 5 túi giống như sheet3 thì vầy.

Private Sub Worksheet_Activate()
Dim I As Long
Sheet3.Range("A2:D40000").Clear
  For I = 1 To 5
    Sheet3.Range("A60000").End(xlUp).Offset(1, 3).Resize(50, 1).Value = I
    Sheet1.Range("A5").Offset(, ((I * 3) - 3)).Resize(50, 3).Copy Sheet3.Range("A60000").End(xlUp).Offset(1)
    Sheet3.Range("A60000").End(xlUp).Offset(1, 3).Resize(50, 1).Clear
   Next
End Sub

Trong sheet 1 của bạn tôi thấy rất nhiều Túi nên không biết là bạn chọn như thế nào chỉ làm theo kq ở sheet3

 

[doveandrose]

Nếu chỉ cần 5 túi giống như sheet3 thì vầy.

Private Sub Worksheet_Activate()
Dim I As Long, ENDR As Range
Sheet3.Range("A2:D40000").Clear
  For I = 1 To 5
    Sheet3.Range("A60000").End(xlUp).Offset(1, 3).Resize(50, 1).Value = I
    Sheet1.Range("A5").Offset(, ((I * 3) - 3)).Resize(50, 3).Copy Sheet3.Range("A60000").End(xlUp).Offset(1)
    Sheet3.Range("A60000").End(xlUp).Offset(1, 3).Resize(50, 1).Clear
   Next
End Sub

Trong sheet 1 của bạn tôi thấy rất nhiều Túi nên không biết là bạn chọn như thế nào chỉ làm theo kq ở sheet3

phải thật chắc chắn nha , chứ các cháu ôn thi mấy năm trời tới cuối cùng bị chú Lê Duy Thương "cắm lộn đầu" 10 điểm thành 0 điểm là chết đó

 

[Lê Duy Thương]

phải thật chắc chắn nha , chứ các cháu ôn thi mấy năm trời tới cuối cùng bị chú Lê Duy Thương "cắm lộn đầu" 10 điểm thành 0 điểm là chết đó

Hỏng hiểu câu anh chim hồng đang nói à nha. Muốn thọ giáo ngoài đời mà anh cứ trốn hoài à nha

 

[dungcpt]

Nếu chỉ cần 5 túi giống như sheet3 thì vầy.

Private Sub Worksheet_Activate()
Dim I As Long, ENDR As Range
Sheet3.Range("A2:D40000").Clear
  For I = 1 To 5
    Sheet3.Range("A60000").End(xlUp).Offset(1, 3).Resize(50, 1).Value = I
    Sheet1.Range("A5").Offset(, ((I * 3) - 3)).Resize(50, 3).Copy Sheet3.Range("A60000").End(xlUp).Offset(1)
    Sheet3.Range("A60000").End(xlUp).Offset(1, 3).Resize(50, 1).Clear
   Next
End Sub

Trong sheet 1 của bạn tôi thấy rất nhiều Túi nên không biết là bạn chọn như thế nào chỉ làm theo kq ở sheet3

Trước hết cám ơn bạn đã.
Có lẽ do mình không nêu hết yêu cầu nên bạn không biết mình muốn thế nào, sorry. Trong sheet3 mình muốn tất cả các bảng trong sheet1 được xếp liền nhau theo hàng dọc ý mà. Chỉ giữ lại duy nhất 1 cái dòng tiêu đề cột như ví dụ trong dữ liệu mẫu thui.
Hì.

 

[doveandrose]

Hỏng hiểu câu anh chim hồng đang nói à nha. Muốn thọ giáo ngoài đời mà anh cứ trốn hoài à nha

hên xui , có thể còn mớ bòng bong ở dưới sheet1 nữa , có thể không .

 

[huuthang_bd]

Trước hết cám ơn bạn đã.
Có lẽ do mình không nêu hết yêu cầu nên bạn không biết mình muốn thế nào, sorry. Trong sheet3 mình muốn tất cả các bảng trong sheet1 được xếp liền nhau theo hàng dọc ý mà. Chỉ giữ lại duy nhất 1 cái dòng tiêu đề cột như ví dụ trong dữ liệu mẫu thui.
Hì.

Code bài #2 chưa được sao bạn?

 

[SA_DQ]

/-)ề nghị các bạn dừng đăng bài tiếp, 1 khi chưa sửa tiêu đề bài viết!

 

[Lê Duy Thương]

Trước hết cám ơn bạn đã.
Có lẽ do mình không nêu hết yêu cầu nên bạn không biết mình muốn thế nào, sorry. Trong sheet3 mình muốn tất cả các bảng trong sheet1 được xếp liền nhau theo hàng dọc ý mà. Chỉ giữ lại duy nhất 1 cái dòng tiêu đề cột như ví dụ trong dữ liệu mẫu thui.
Hì.

THÌ THỬ XEM FILE NHÉ. TẠM THỜI CHƯA NGHĨ ĐƯỢC CÁCH HAY HƠN

Option Explicit


Sub KQsheet2()
Dim FoundItems As Range, FirstAddress As String, Items As Variant, Foundrg As Range
Sheet2.Range("A:H").Clear
Set Foundrg = Sheet1.Range("A2:O20000")
With Foundrg
  Items = "TT"
    Set FoundItems = .FIND(What:=Items, LookIn:=xlFormulas, LookAt:=xlWhole)
    If Not FoundItems Is Nothing Then
        FirstAddress = FoundItems.Address
        Do
           With FoundItems
                 Sheet2.Range("A20000").End(3).Offset(2, 3).Value = "M" & ChrW(227) & " T" & ChrW(250) & "i" '
                 Sheet2.Range("A20000").End(3).Offset(3, 3).Resize(FoundItems.End(xlDown), 1).FormulaR1C1 = "=IF(R[-1]C1=""TT"",RIGHT(R[-2]C1,LEN(R[-2]C1)-5),R[-1]C4)"
                .Offset(-1).Resize(FoundItems.End(xlDown) + 3, 3).copy Sheet2.Range("A20000").End(3).Offset(1)
                 
           End With
           Set FoundItems = .FindNext(FoundItems)
        Loop While Not FoundItems Is Nothing And FoundItems.Address <> FirstAddress
    End If
End With
Sheet2.Range("A3").CurrentRegion.Value = Range("A3").CurrentRegion.Value
    
End Sub

Sub KQsheet3()
    Sheet3.Range("A:D").Clear
    If Sheet2.[A3] = "" Then Exit Sub
    Sheet2.Range("A3").CurrentRegion.Offset(1).AutoFilter Field:=4, Criteria1:=">=1"
    Sheet2.Range("A3").CurrentRegion.Offset(1).copy Sheet3.Range("A1")
    Application.CutCopyMode = False
    Sheet2.Range("A3").CurrentRegion.Offset(1).AutoFilter
End Sub

 

[dungcpt]

Cám ơn bạn, kết quả đúng như ý mình, mình sẽ thử với các bảng dữ liệu khác cùng loại.

THÌ THỬ XEM FILE NHÉ. TẠM THỜI CHƯA NGHĨ ĐƯỢC CÁCH HAY HƠN

Option Explicit


Sub KQsheet2()
Dim FoundItems As Range, FirstAddress As String, Items As Variant, Foundrg As Range
Sheet2.Range("A:H").Clear
Set Foundrg = Sheet1.Range("A2:O20000")
With Foundrg
  Items = "TT"
    Set FoundItems = .FIND(What:=Items, LookIn:=xlFormulas, LookAt:=xlWhole)
    If Not FoundItems Is Nothing Then
        FirstAddress = FoundItems.Address
        Do
           With FoundItems
                 Sheet2.Range("A20000").End(3).Offset(2, 3).Value = "M" & ChrW(227) & " T" & ChrW(250) & "i" '
                 Sheet2.Range("A20000").End(3).Offset(3, 3).Resize(FoundItems.End(xlDown), 1).FormulaR1C1 = "=IF(R[-1]C1=""TT"",RIGHT(R[-2]C1,LEN(R[-2]C1)-5),R[-1]C4)"
                .Offset(-1).Resize(FoundItems.End(xlDown) + 3, 3).copy Sheet2.Range("A20000").End(3).Offset(1)
                 
           End With
           Set FoundItems = .FindNext(FoundItems)
        Loop While Not FoundItems Is Nothing And FoundItems.Address <> FirstAddress
    End If
End With
Sheet2.Range("A3").CurrentRegion.Value = Range("A3").CurrentRegion.Value
    
End Sub

Sub KQsheet3()
    Sheet3.Range("A:D").Clear
    If Sheet2.[A3] = "" Then Exit Sub
    Sheet2.Range("A3").CurrentRegion.Offset(1).AutoFilter Field:=4, Criteria1:=">=1"
    Sheet2.Range("A3").CurrentRegion.Offset(1).copy Sheet3.Range("A1")
    Application.CutCopyMode = False
    Sheet2.Range("A3").CurrentRegion.Offset(1).AutoFilter
End Sub