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

Liên hệ QC

Người dùng đang xem chủ đề này

Đang trực tuyến: 1 (Thành viên: 0, Khách: 1)
A

Anh Nguyên Minh Anh

Thành viên mới
Tham gia
18/3/22
Bài viết
7
Được thích
0
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 ạ.
1.jpg
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 ạ.

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

File đính kèm

Lần chỉnh sửa cuối:
Sắp xếp theo thời gian sắp xếp theo bầu chọn
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
 
Upvote 0
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 ạ.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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 ạ.
Nhấp chuột vào đây để mở rộng...
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 ạ.
Nhấp chuột vào đây để mở rộng...
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
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
em cảm ơn anh nhiều ạ.
 
Upvote 0
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
Nhấp chuột vào đây để mở rộng...
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ỹ)
 

File đính kèm

Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

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

Quang Ròm
  • Question Question
VBA nhảy qua lại 2 cột A B (1 người xem)
    • Cười
Trả lời
5
Đọc
55
Quang Ròm
Quang Ròm
S
Hỏi về công thức tính tiền công theo Kg, có điều kiện. (1 người xem)
Trả lời
0
Đọc
14
saicmf
S
N
Cho em xin hỏi về hàm Workday về ngày làm bù ạ
Trả lời
1
Đọc
25
hoangtuaotrang_hp_vn
H
K
dùng hàm sumproduct kết hợp nhiều điều kiện như thế nào?
Trả lời
2
Đọc
37
khanhnth02
K
tranaidh
Giúp sắp xếp phòng thi tốt nghiệp năm 2025
Trả lời
4
Đọc
246
BuiQuangThuan
B
V
Cập nhật DataValidation 2 chiều giữa 2 sheet
Trả lời
4
Đọc
167
hoangtuaotrang_hp_vn
H
nghiahandsome1995
  • Question Question
in đậm chuỗi văn bản bằng excel
Trả lời
11
Đọc
296
HUONGHCKT
H
nghiahandsome1995
Xin mã code autofit
Trả lời
0
Đọc
29
nghiahandsome1995
nghiahandsome1995
D
tạo pivot table theo nhiều trường dữ liệu phân loại
Trả lời
4
Đọc
93
duymax1234567
D
H
Cách nào có thể gộp dữ liệu không dùng VBA
Trả lời
9
Đọc
116
Hoang NS
H
B
Xin tư vấn excel tính giá trị cho nhiều trường hợp
    • Ngạc nhiên
    • Phẫn nộ
Trả lời
5
Đọc
278
hangnguyenkt
H
A
Giúp đỡ tính tổng ô hàng ngang bất kỳ !
Trả lời
8
Đọc
193
anhdung411
A
T
  • Question Question
Ẩn hiện các sheet khi click vào HyperLink
Trả lời
5
Đọc
166
DeTong
D
PhanTuHuong
Hà Nội hẹn hò gặp gỡ đầu năm 2025 thôi :)
    • Thích
    • Yêu thích
Trả lời
5
Đọc
246
PhanTuHuong
PhanTuHuong
DinhManh1307
Cách thống kê công việc sản xuất từng người để tính lương sản phẩm
Trả lời
6
Đọc
79
DeTong
D
T
Bảng tính trợ cấp theo Nghị định 178 và tính lương hưu
    • Thích
Trả lời
8
Đọc
785
thanhkhoavp
T
sangvanng92
  • Question Question
Cách chạy file excel chứa code vba trên sharepoint
Trả lời
2
Đọc
141
Nguyễn Duy Tuân
Nguyễn Duy Tuân
ankhanh2k2
sắp xếp dữ liệu chấm công
    • Buồn
Trả lời
8
Đọc
247
pycckuu410
P
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ
    • Thích
    • Cảm ơn
Trả lời
6
Đọc
868
PhanTuHuong
PhanTuHuong
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
4
Đọc
121
HeSanbi
HeSanbi
Xem thêm…

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

Đếm ngược thời gian

000
Ngày
00
Giờ
00
phút
00
giây
TALK SHOW EXCEL TRONG SẢN XUẤT
Back
Top Bottom