Thống kê dữ liệu từ 1 cột sang các mục tương ứng của sheet khác

Anh Nguyên Minh Anh · 18/3/22

Em chào tất cả anh chị em trên diễn đàn. Em có bảng dữ liệu trong sheets " Nhap " muốn chuyển sang các mục tương ứng trong sheets " Tổng Hợp " ạ.
Chữ màu đỏ là những mục tương ứng trong sheets " Nhap " và sheets " Tổng Hợp ", còn chữ màu đen là nội dung cần chuyển từ sheets " Nhap " sang các mục tương ứng của sheets " Tổng Hợp " , và sắp xếp lại vị trí hồ sơ theo thứ tự từ bé đến lớn từ dòng trên xuống ạ.

Kết quả em mong muốn cuối cùng đây ạ. Em nhập tay được mấy dòng ạ, nhập từ dưới lên ạ.

Nhờ mọi người giúp em đoạn code vba , em xin cảm ơn ạ.

Anh Nguyên Minh Anh · 19/3/22

Em tìm và sửa được đoạn code này, nhờ mọi người sửa giúp em vì có những dòng được ngăn cách bởi dấu gạch ngang nên em không tách ra được ạ.

Mã:

Sub Chuyen_TuDuoiLen()
        Dim lr As Long, lr1 As Long
        With Sheet2
            lr = .Range("A1000000").End(xlUp).Row
            lr1 = Sheet1.Range("A1000000").End(xlUp).Row
           .Range("A" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 19)), 15), 10)
           .Range("B" & lr + 1).Value = Right(Sheet1.Range("A" & (lr1 - 19)), 4)
           .Range("C" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 18))
           .Range("D" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 16))
           .Range("E" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 14))
           .Range("F" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 12))
           .Range("G" & lr + 1).Value = Left(Sheet1.Range("A" & (lr1 - 10)), 10)
           .Range("H" & lr + 1).Value = Right(Sheet1.Range("A" & (lr1 - 10)), Len(Sheet1.Range("A" & (lr1 - 10))) - 13)
           '.Range("I" & lr + 1).Value = Left(Sheet1.Range("A" & (lr1 - 8)), 5)
           '.Range("J" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 13), 5)
           '.Range("K" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 21), 5)
           '.Range("L" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 29), 5)
           '.Range("M" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 37), 5)
           '.Range("N" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 45), 5)
           '.Range("O" & lr + 1).Value = Right(Sheet1.Range("A" & (lr1 - 8)), 5)
           .Range("P" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 6))
           '.Range("Q" & lr + 1).Value = Left(Sheet1.Range("A" & (lr1 - 4)), 3)
           '.Range("R" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 4)), 11), 4)
           '.Range("S" & lr + 1).Value = Right(Sheet1.Range("A" & (lr1 - 4)), 4)
           .Range("T" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 2))
           .Range("U" & lr + 1).Value = Sheet1.Range("A" & lr1)
        End With
        delete_row
End Sub
Sub delete_row()
Dim lr As Long
    With Sheet1
        lr = .Range("A1000000").End(xlUp).Row
        .Range("A" & lr - 19, "A" & lr).Delete Shift:=xlUp
    End With
End Sub

snow25 · 19/3/22

Anh Nguyên Minh Anh đã viết:
Em chào tất cả anh chị em trên diễn đàn. Em có bảng dữ liệu trong sheets " Nhap " muốn chuyển sang các mục tương ứng trong sheets " Tổng Hợp " ạ.
Chữ màu đỏ là những mục tương ứng trong sheets " Nhap " và sheets " Tổng Hợp ", còn chữ màu đen là nội dung cần chuyển từ sheets " Nhap " sang các mục tương ứng của sheets " Tổng Hợp " , và sắp xếp lại vị trí hồ sơ theo thứ tự từ bé đến lớn từ dòng trên xuống ạ.
View attachment 273320
Kết quả em mong muốn cuối cùng đây ạ. Em nhập tay được mấy dòng ạ, nhập từ dưới lên ạ.

View attachment 273346
Nhờ mọi người giúp em đoạn code vba , em xin cảm ơn ạ.

Thử code này xem.

Mã:

Sub tach()
   Dim i As Long, lr As Long, T, arr, kq, a As Long, b As Long
   With Sheets("Nhap")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:A" & lr).Value
        If UBound(arr) Mod 20 <> 0 Then Exit Sub
        b = UBound(arr) \ 20
        ReDim kq(1 To b, 1 To 21)
   End With
       For i = UBound(arr) To 1 Step -20
           a = a + 1
           kq(a, 21) = arr(i, 1)
           kq(a, 20) = arr(i - 2, 1)
           T = Split(arr((i - 4), 1), " - ")
           kq(a, 19) = T(2)
           kq(a, 18) = T(1)
           kq(a, 17) = T(0)
           kq(a, 16) = arr(i - 6, 1)
           T = Split(arr((i - 8), 1), " - ")
           kq(a, 15) = T(6)
           kq(a, 14) = T(5)
           kq(a, 13) = T(4)
           kq(a, 12) = T(3)
           kq(a, 11) = T(2)
           kq(a, 10) = T(1)
           kq(a, 9) = T(0)
           T = Split(arr((i - 10), 1), " - ")
           kq(a, 8) = T(1)
           kq(a, 7) = T(0)
           kq(a, 6) = arr(i - 12, 1)
           kq(a, 5) = arr(i - 14, 1)
           kq(a, 4) = arr(i - 16, 1)
           kq(a, 3) = arr(i - 18, 1)
           T = Split(arr((i - 19), 1), " ")
           kq(a, 2) = T(2)
           kq(a, 1) = T(1)
       Next i
  With Sheet2
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 3 Then .Range("A4:U" & lr).ClearContents
       .Range("A4:U4").Resize(a).Value = kq
  End With
End Sub

HieuCD · 19/3/22

Anh Nguyên Minh Anh đã viết:
Em chào tất cả anh chị em trên diễn đàn. Em có bảng dữ liệu trong sheets " Nhap " muốn chuyển sang các mục tương ứng trong sheets " Tổng Hợp " ạ.
Chữ màu đỏ là những mục tương ứng trong sheets " Nhap " và sheets " Tổng Hợp ", còn chữ màu đen là nội dung cần chuyển từ sheets " Nhap " sang các mục tương ứng của sheets " Tổng Hợp " , và sắp xếp lại vị trí hồ sơ theo thứ tự từ bé đến lớn từ dòng trên xuống ạ.

Kết quả em mong muốn cuối cùng đây ạ. Em nhập tay được mấy dòng ạ, nhập từ dưới lên ạ.

Nhờ mọi người giúp em đoạn code vba , em xin cảm ơn ạ.

Kiểm tra lại . . .

Mã:

Option Explicit
Sub ABC()
  Dim sArr(), res(), aDong, aCot, S
  Dim sRow&, i&, k&, j&, c&, fCol&, eCol&, tmp
 
  aDong = Array(1, 2, 4, 6, 8, 10, 12, 14, 16, 18, 20)
  aCot = Array("1-2", 3, 4, 5, 6, "7-8", "9-15", 16, "17-19", 20, 21)
  With Sheet1
    sArr = .Range("A2", .Range("A999999").End(xlUp)).Value
  End With
  sRow = UBound(sArr) - 1
  ReDim res(1 To (sRow + 1) \ 20, 1 To 21)
  For i = 0 To sRow Step 20
    k = k + 1
    For j = 0 To 10
      tmp = sArr(i + aDong(j), 1)
      If IsNumeric(aCot(j)) Then
        res(k, aCot(j)) = tmp
      ElseIf j = 0 Then
        S = Split(Application.Trim(Replace(tmp, "-", " ")), " ")
        res(k, 1) = S(1)
        res(k, 2) = S(2)
      Else
        S = Split(aCot(j), "-")
        fCol = S(0)
        eCol = S(1)
        S = Split(tmp, "-")
        For c = fCol To eCol
          res(k, c) = Trim(S(c - fCol))
        Next c
      End If
    Next j
    res(k, 11) = Replace(res(k, 11), ",", ".")
    res(k, 19) = Replace(res(k, 19), ",", ".")
  Next i
  i = Sheet2.Range("A999999").End(xlUp).Row
  If i > 3 Then Sheet2.Range("A4:U" & i).Clear
  Sheet2.Range("A4").Resize(k, 21).NumberFormat = "@"
  Sheet2.Range("Q4:S4").Resize(k).NumberFormat = "General"
  Sheet2.Range("I4:K4").Resize(k).NumberFormat = "General"
  Sheet2.Range("A4").Resize(k, 21) = res
  Sheet2.Range("A4").Resize(k, 21).Sort Sheet2.Range("B4"), 1, Header:=xlNo
End Sub

Anh Nguyên Minh Anh · 19/3/22

snow25 đã viết:

Thử code này xem.

Mã:

Sub tach()
   Dim i As Long, lr As Long, T, arr, kq, a As Long, b As Long
   With Sheets("Nhap")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        arr = .Range("A2:A" & lr).Value
        If UBound(arr) Mod 20 <> 0 Then Exit Sub
        b = UBound(arr) \ 20
        ReDim kq(1 To b, 1 To 21)
   End With
       For i = UBound(arr) To 1 Step -20
           a = a + 1
           kq(a, 21) = arr(i, 1)
           kq(a, 20) = arr(i - 2, 1)
           T = Split(arr((i - 4), 1), " - ")
           kq(a, 19) = T(2)
           kq(a, 18) = T(1)
           kq(a, 17) = T(0)
           kq(a, 16) = arr(i - 6, 1)
           T = Split(arr((i - 8), 1), " - ")
           kq(a, 15) = T(6)
           kq(a, 14) = T(5)
           kq(a, 13) = T(4)
           kq(a, 12) = T(3)
           kq(a, 11) = T(2)
           kq(a, 10) = T(1)
           kq(a, 9) = T(0)
           T = Split(arr((i - 10), 1), " - ")
           kq(a, 8) = T(1)
           kq(a, 7) = T(0)
           kq(a, 6) = arr(i - 12, 1)
           kq(a, 5) = arr(i - 14, 1)
           kq(a, 4) = arr(i - 16, 1)
           kq(a, 3) = arr(i - 18, 1)
           T = Split(arr((i - 19), 1), " ")
           kq(a, 2) = T(2)
           kq(a, 1) = T(1)
       Next i
  With Sheet2
       lr = .Range("A" & Rows.Count).End(xlUp).Row
       If lr > 3 Then .Range("A4:U" & lr).ClearContents
       .Range("A4:U4").Resize(a).Value = kq
  End With
End Sub

em cảm ơn anh nhiều ạ.

HUONGHCKT · 19/3/22

Anh Nguyên Minh Anh đã viết:

Em tìm và sửa được đoạn code này, nhờ mọi người sửa giúp em vì có những dòng được ngăn cách bởi dấu gạch ngang nên em không tách ra được ạ.

Mã:

Sub Chuyen_TuDuoiLen()
        Dim lr As Long, lr1 As Long
        With Sheet2
            lr = .Range("A1000000").End(xlUp).Row
            lr1 = Sheet1.Range("A1000000").End(xlUp).Row
           .Range("A" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 19)), 15), 10)
           .Range("B" & lr + 1).Value = Right(Sheet1.Range("A" & (lr1 - 19)), 4)
           .Range("C" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 18))
           .Range("D" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 16))
           .Range("E" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 14))
           .Range("F" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 12))
           .Range("G" & lr + 1).Value = Left(Sheet1.Range("A" & (lr1 - 10)), 10)
           .Range("H" & lr + 1).Value = Right(Sheet1.Range("A" & (lr1 - 10)), Len(Sheet1.Range("A" & (lr1 - 10))) - 13)
           '.Range("I" & lr + 1).Value = Left(Sheet1.Range("A" & (lr1 - 8)), 5)
           '.Range("J" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 13), 5)
           '.Range("K" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 21), 5)
           '.Range("L" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 29), 5)
           '.Range("M" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 37), 5)
           '.Range("N" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 8)), 45), 5)
           '.Range("O" & lr + 1).Value = Right(Sheet1.Range("A" & (lr1 - 8)), 5)
           .Range("P" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 6))
           '.Range("Q" & lr + 1).Value = Left(Sheet1.Range("A" & (lr1 - 4)), 3)
           '.Range("R" & lr + 1).Value = Right(Left(Sheet1.Range("A" & (lr1 - 4)), 11), 4)
           '.Range("S" & lr + 1).Value = Right(Sheet1.Range("A" & (lr1 - 4)), 4)
           .Range("T" & lr + 1).Value = Sheet1.Range("A" & (lr1 - 2))
           .Range("U" & lr + 1).Value = Sheet1.Range("A" & lr1)
        End With
        delete_row
End Sub
Sub delete_row()
Dim lr As Long
    With Sheet1
        lr = .Range("A1000000").End(xlUp).Row
        .Range("A" & lr - 19, "A" & lr).Delete Shift:=xlUp
    End With
End Sub

Tôi code lại cho bạn. Hãy thử xem sao.
Nhấn nút TÔNG HƠP để xem kết quả===> kiểm tra lại. (tôi chưa test kỹ)

Thống kê dữ liệu từ 1 cột sang các mục tương ứng của sheet khác

Anh Nguyên Minh Anh

Thành viên mới

File đính kèm

Anh Nguyên Minh Anh

Thành viên mới

snow25

Thành viên gạo cội

HieuCD

Chuyên gia GPE

Anh Nguyên Minh Anh

Thành viên mới

HUONGHCKT

Zalo 0986997214

File đính kèm

Bài viết mới nhất

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng