giúp em code cho nút sắp xếp dữ liệu (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)
Q

quoc nhat

Thành viên tiêu biểu
Tham gia
8/3/12
Bài viết
567
Được thích
43
Nghề nghiệp
cán bộ ngành y tế
Chào các anh chị và thầy cô.
Em có file muốn nhờ các anh chị giúp đỡ.
Em cần code cho nút SẮP XẾP DỮ LIỆU ở sheet1.
yêu cầu của em ở sheet3 các anh chị và thầy cô xem qua và giúp em với.
Em cảm ơn
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Bạn thử với Code này
Mã: 
Sub SortBHYT()
Dim Arr, ArrSt, ResArr, SortString As String, PosSort As Long, Tmp
Dim i As Long, j As Long, c As Long


'Thiet dat vung du lieu
Arr = Sheet1.Range("A2:G" & Sheet1.Range("A65536").End(3).Row)
ArrSt = Sheet3.Range("B2:B" & Sheet3.Range("B65536").End(3).Row)
ReDim ResArr(1 To UBound(Arr, 1), 1 To UBound(Arr, 2))


For i = 1 To UBound(ArrSt, 1)
    SortString = SortString & "#" & UCase(ArrSt(i, 1))
Next
SortString = SortString & "#"


'Gan vi tri sort vao Arr
For i = 1 To UBound(Arr, 1)
    PosSort = InStr(1, SortString, "#" & UCase(Left(Arr(i, 1), 2)))
    ResArr(i, 1) = PosSort & "#" & Arr(i, 1)
    For j = 2 To UBound(Arr, 2)
        ResArr(i, j) = Arr(i, j)
    Next
Next


'Sort ResArr dua tren tien to vua them
For i = 1 To UBound(ResArr, 1) - 1
    For j = i + 1 To UBound(ResArr, 1)
        If ResArr(i, 1) > ResArr(j, 1) Then
            For c = 1 To UBound(ResArr, 2)
                Tmp = ResArr(i, c)
                ResArr(i, c) = ResArr(j, c)
                ResArr(j, c) = Tmp
            Next
        End If
    Next
Next


'Tra lai gia tri Arr(i,1)
For i = 1 To UBound(Arr, 1)
    ResArr(i, 1) = Right(ResArr(i, 1), Len(ResArr(i, 1)) - InStr(1, ResArr(i, 1), "#"))
Next
Sheet1.[A2].Resize(UBound(Arr, 1), UBound(ResArr, 2)) = ResArr
End Sub
 

File đính kèm

Upvote 0
dhn46 đã viết:
Bạn thử với Code này
Mã: 
Sub SortBHYT()
......
End Sub
Nhấp chuột vào đây để mở rộng...

cảm ơn anh vì đã nhiệt tình giúp đỡ vì em gửi bài hơi muộn.
danh sách trên là em nhập từ form xuống nhưng code của anh dhn46 không sắp xếp được các dữ liệu gần nhau theo thứ tự được( tức là cái nào được nhập trước từ trên xuống thì được sắp xếp nằm liền kề nhau giống kiểu dồn dữ liệu lại đấy anh ) chứ không phải sắp xếp theo thứ tự chữ cái như trong code của anh.
anh kiểm tra giúp em với
cảm ơn anh một lần nữa
 
Upvote 0
quoc nhat đã viết:
cảm ơn anh vì đã nhiệt tình giúp đỡ vì em gửi bài hơi muộn.
danh sách trên là em nhập từ form xuống nhưng code của anh dhn46 không sắp xếp được các dữ liệu gần nhau theo thứ tự được( tức là cái nào được nhập trước từ trên xuống thì được sắp xếp nằm liền kề nhau giống kiểu dồn dữ liệu lại đấy anh ) chứ không phải sắp xếp theo thứ tự chữ cái như trong code của anh.
anh kiểm tra giúp em với
cảm ơn anh một lần nữa
Nhấp chuột vào đây để mở rộng...
Thử code này thử xem, tạm đưa kết quả qua sheet3, nếu muốn ghi luôn vào sheet1 thì bạn tự sửa lại.
PHP: 
Public Sub GPE()
Dim Ar1(), Ar2(), Arr(), I As Long, J As Long, K As Long, N As Long, Tem As String
With Sheet1
Ar1 = .Range(.[J1], .[J1000].End(xlUp)).Value
Ar2 = .Range(.[A2], .[A65000].End(xlUp)).Resize(, 7).Value
End With
ReDim Arr(1 To UBound(Ar2, 1), 1 To 7)
For N = 1 To UBound(Ar1, 1)
    Tem = UCase(Ar1(N, 1))
    For I = 1 To UBound(Ar2, 1)
        If UCase(Left(Ar2(I, 1), 2)) = Tem Then
            K = K + 1
            For J = 1 To 7
                Arr(K, J) = Ar2(I, J)
            Next J
        End If
    Next I
Next N
Sheet3.[A2].Resize(K, 7).Value = Arr
End Sub
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Thực sự không hiểu yêu cầu của bạn* Bài #1: Yêu cầu sắp xếp theo 2 ký tự đầu của mã thẻ BHXH dựa theo list thứ tự tại sheet3
* Bài #3: Yêu cầu dồn dòng, cái nào nhập trước từ Form thì lên trước....
Nhìn lại File bạn gửi thì: không có Code nhập từ Form, không có kết quả mẫu
Thôi thì đợi các cao thủ khác ra tay vậy, mình không giỏi "đoán".
Thân!
 
Upvote 0
Em cũng mới học mảng nên cũng thử sức ( có gì mong các thầy chỉ thêm ạ ). Code này e chỉ mới quan tâm cột BHYT xếp theo yêu cầu đề ra . Giá trị đưa về sheet3. A kiểm tra xem đúng yêu cầu chưa :
PHP: 
Sub quay()
Dim arr1(), arr2(), arr(), i As Long, j As Long, k As Long, tem As String
arr1 = Sheet1.Range("A2", Sheet1.[A65000].End(3)).Resize(, 7).Value
arr2 = Sheet3.Range("A4:A20").Value
ReDim arr(1 To UBound(arr1, 1), 1 To 1)
For i = 1 To UBound(arr2, 1)
        For j = 1 To UBound(arr1, 1)
            tem = Left(UCase(arr1(j, 1)), 2)
            If tem = arr2(i, 1) Then
                k = k + 1
                arr(k, 1) = arr1(j, 1)
            End If
        Next j
Next i
Sheet3.[E2].Resize(k, 1) = arr
                
End Sub
 
Upvote 0
dhn46 đã viết:
Thực sự không hiểu yêu cầu của bạn* Bài #1: Yêu cầu sắp xếp theo 2 ký tự đầu của mã thẻ BHXH dựa theo list thứ tự tại sheet3
* Bài #3: Yêu cầu dồn dòng, cái nào nhập trước từ Form thì lên trước....
Nhìn lại File bạn gửi thì: không có Code nhập từ Form, không có kết quả mẫu
Thôi thì đợi các cao thủ khác ra tay vậy, mình không giỏi "đoán".
Thân!
Nhấp chuột vào đây để mở rộng...
Dạ thưa anh
đây là file em copy từ File khác qua nên không có code nhập liệu
Em xin lỗi không nói từ trước
em gửi mẫu lên anh xem nhé
Không giống lắm nhưng em muốn nó sắp xếp kiểu thế này
Từ code của anh em muốn chế nó cho file mẫu của em không biết có được không
 

File đính kèm

Upvote 0
Em gửi lại file cho a, em chỉnh chút xíu trong code.
 

File đính kèm

Upvote 0
quoc nhat đã viết:
Chào các anh chị và thầy cô.
Em có file muốn nhờ các anh chị giúp đỡ.
Em cần code cho nút SẮP XẾP DỮ LIỆU ở sheet1.
yêu cầu của em ở sheet3 các anh chị và thầy cô xem qua và giúp em với.
Em cảm ơn
Nhấp chuột vào đây để mở rộng...

Có 1 cách khá đơn giản để làm bài này:
- Đầu tiên sang sheet 3, lấy danh sách (A4:A20) cho vào Custom List
- Xong, sang sheet1, tạo 1 cột phụ và lấy LEFT 2 ký tự của mã BHYT
- Gọi lệnh sort và sort theo cái Custom list đã add
 
Upvote 0
quoc nhat đã viết:
Dạ thưa anh
đây là file em copy từ File khác qua nên không có code nhập liệu
Em xin lỗi không nói từ trước
em gửi mẫu lên anh xem nhé
Không giống lắm nhưng em muốn nó sắp xếp kiểu thế này
Từ code của anh em muốn chế nó cho file mẫu của em không biết có được không
Nhấp chuột vào đây để mở rộng...
1/ Nếu bạn nói từ trước rằng: chỉ cần nhóm mã thẻ theo 2 ký tự đầu dựa vào sheet3 - Không sắp xếp trong nhóm theo mã thẻ thì Code đã gọn và nhanh hơn rất nhiều.
2/ Vấn đề tạo Report của bạn hoàn toàn có thể làm được, bạn cần hiểu quy trình để lập trình ra 1 bản báo cáo, đọc dữ lieu của bạn và mình phân tích như sau để bạn tùy biến. (Cái này bạn nên tìm hiểu dần để thực hành)
* Bạn dựa vào sheet nhập dữ liệu của bạn để nhóm các đầu mục lại, trong quá trình nhóm thực hiện tính toán luôn. Khi hết các nhóm bạn tạo các dòng trống trong mảng (mục đích để chèn phần tổng, cộng... trong báo cáo). Cuối cùng xuất dữ liệu.
Hy vọng hướng đi đó sẽ giúp bạn tìm hiểu được nhiều hơn về VBA

Thân!
 
Upvote 0
ndu96081631 đã viết:
Có 1 cách khá đơn giản để làm bài này:
- Đầu tiên sang sheet 3, lấy danh sách (A4:A20) cho vào Custom List
- Xong, sang sheet1, tạo 1 cột phụ và lấy LEFT 2 ký tự của mã BHYT
- Gọi lệnh sort và sort theo cái Custom list đã add
Nhấp chuột vào đây để mở rộng...
cuối cùng thì thầy cũng xuất hiện
Cách của thầy rất hay
cảm ơn thầy
 
Upvote 0
dhn46 đã viết:
1/ Nếu bạn nói từ trước rằng: chỉ cần nhóm mã thẻ theo 2 ký tự đầu dựa vào sheet3 - Không sắp xếp trong nhóm theo mã thẻ thì Code đã gọn và nhanh hơn rất nhiều.
2/ Vấn đề tạo Report của bạn hoàn toàn có thể làm được, bạn cần hiểu quy trình để lập trình ra 1 bản báo cáo, đọc dữ lieu của bạn và mình phân tích như sau để bạn tùy biến. (Cái này bạn nên tìm hiểu dần để thực hành)
* Bạn dựa vào sheet nhập dữ liệu của bạn để nhóm các đầu mục lại, trong quá trình nhóm thực hiện tính toán luôn. Khi hết các nhóm bạn tạo các dòng trống trong mảng (mục đích để chèn phần tổng, cộng... trong báo cáo). Cuối cùng xuất dữ liệu.
Hy vọng hướng đi đó sẽ giúp bạn tìm hiểu được nhiều hơn về VBA

Thân!
Nhấp chuột vào đây để mở rộng...
Do yêu cầu bên quản lý khám chữa bệnh của BHYT đòi hỏi gấp quá mà em chỉ mới học viết VBA thôi nên cách anh chỉ em sẽ tìm hiểu dần dần.
trước mắt : anh xem có thể giúp em tạo được một File như vậy được không?
sau này em tìm hiểu và hoàn thiện nó hơn
cảm ơn anh
 
Upvote 0
dhn46 đã viết:
1/ Nếu bạn nói từ trước rằng: chỉ cần nhóm mã thẻ theo 2 ký tự đầu dựa vào sheet3 - Không sắp xếp trong nhóm theo mã thẻ thì Code đã gọn và nhanh hơn rất nhiều.
2/ Vấn đề tạo Report của bạn hoàn toàn có thể làm được, bạn cần hiểu quy trình để lập trình ra 1 bản báo cáo, đọc dữ lieu của bạn và mình phân tích như sau để bạn tùy biến. (Cái này bạn nên tìm hiểu dần để thực hành)
* Bạn dựa vào sheet nhập dữ liệu của bạn để nhóm các đầu mục lại, trong quá trình nhóm thực hiện tính toán luôn. Khi hết các nhóm bạn tạo các dòng trống trong mảng (mục đích để chèn phần tổng, cộng... trong báo cáo). Cuối cùng xuất dữ liệu.
Hy vọng hướng đi đó sẽ giúp bạn tìm hiểu được nhiều hơn về VBA

Thân!
Nhấp chuột vào đây để mở rộng...
"NẢY SINH Ý TƯỞNG MÀ KHÔNG BIẾT LẬP TRÌNH NTN"
Như ở bài 1 và file mẫu của em gửi cho anh và sự hướng dẫn của anh thì phần nào anh đã hiểu yêu cầu của em. Thôi thì anh giúp em phần sort và chuyển dữ liệu từ sheet1 sang sheet 2 giúp em với.
Code trên Form anh nhé command Tạo Báo Cáo( gồm code sort và chuyển DL từ sheet1 sang sheet 2). Vì em chỉ muốn thực hiện thao tác trên Form mà không muốn nhìn qua sheet. Anh ơi có thể tự động chèn thêm dòng nếu dữ liệu của mỗi nhóm nhiều hơn được không? Anh cố gắng giúp em nhé
em cảm ơn anh nhiều
 

File đính kèm

Upvote 0
Tôi làm cho bạn, hy vọng bạn sẽ bỏ nhiều thời gian hơn để học và tùy biến cho mình. Code chính
Mã: 
Public Sub REPORT()
Dim Arr, Res, ArrCode
Dim i As Long, j As Long, k As Long, c As Long, Stt As Long, CheckExist As Long
Dim sTotalDT As Long 'Tong con dich truyen cua moi ma
Dim sTotalCk As Long 'Tong con cong kham moi ma
Dim GTotalDT As Long 'Tong con dich truyen cua moi nhom
Dim GTotalCk As Long 'Tong con cong kham moi nhom
Dim TotalDT As Long 'Tong con dich truyen cua moi nhom
Dim TotalCk As Long 'Tong con cong kham moi nhom
Dim Dt As Long  'Tong tat ca dich truyen
Dim Ck As Long  'Tong tat ca cong kham
Sheets("Report").[A9:A10000].EntireRow.Delete
Arr = Sheets("DATA").Range("A3:Q" & Sheets("data").Range("A65536").End(3).Row)
ArrCode = Sheets("INF").Range("B3:C" & Sheets("INF").Range("B65536").End(3).Row)
ReDim Res(1 To UBound(Arr, 1) + 40, 1 To UBound(Arr, 2) + 1)
For i = 1 To UBound(ArrCode, 1)
    'Reset cac tong cua ma
    sTotalDT = 0
    sTotalCk = 0
    
    CheckExist = k      'Dung de kiem tra xem co ma thuoc nhom hay khong
    For j = 1 To UBound(Arr, 1)
        If UCase(Left(Arr(j, 4), 2)) = UCase(ArrCode(i, 1)) Then
            k = k + 1: Stt = Stt + 1
            Res(k, 1) = Stt
            For c = 1 To UBound(Arr, 2)
                Res(k, c + 1) = Arr(j, c)
            Next c
            sTotalDT = sTotalDT + Arr(j, 10)
            sTotalCk = sTotalCk + Arr(j, 15)
        End If
    Next j
'Ket thuc 1 ma thi them dong, Neu khong ton tai ma thi ko them
    If k > CheckExist Then
        k = k + 1
        Res(k, 2) = "Céng " & ArrCode(i, 1)
        Res(k, 5) = ArrCode(i, 1)
        Res(k, 11) = sTotalDT
        Res(k, 16) = sTotalCk
        Res(k, 18) = sTotalCk + sTotalDT
        GTotalDT = GTotalDT + sTotalDT
        GTotalCk = GTotalCk + sTotalCk
    End If
'Cong them dong khi ket thuc 1 nhom
    If i < UBound(ArrCode, 1) Then
        If ArrCode(i + 1, 2) > ArrCode(i, 2) Then
            k = k + 1
            Res(k, 2) = "Céng " & ArrCode(i, 2)
            Res(k, 11) = GTotalDT
            Res(k, 16) = GTotalCk
            Res(k, 18) = GTotalCk + GTotalDT
            
            k = k + 1
            Res(k, 2) = "Nhãm " & ArrCode(i + 1, 2)
            TotalDT = TotalDT + GTotalDT
            TotalCk = TotalCk + GTotalCk
            Ck = Ck + TotalCk
            Dt = Dt + TotalDT
            'Reset cac tong cua nhom
            GTotalDT = 0
            GTotalCk = 0
        End If
    Else
        k = k + 1
        Res(k, 2) = "Tæng céng I+II+III+IV+V+VI"
        Res(k, 11) = Dt
        Res(k, 16) = Ck
        Res(k, 18) = Ck + Dt
    End If
Next i
Sheets("Report").[A9].Resize(UBound(Res, 1), UBound(Res, 2)) = Res
With Application.Intersect([A9:S65536], Sheets("Report").Range("A9:A" & Sheets("Report").Range("A65536").End(3).Row + 2).SpecialCells(xlCellTypeBlanks).EntireRow)
    .Interior.ColorIndex = 44
    .Font.Bold = True
    .Font.Italic = True
End With
End Sub
 

File đính kèm

Upvote 0
Mã: 
Public Sub REPORT()
Dim Arr, Res, ArrCode
Dim i As Long, j As Long, k As Long, c As Long, Stt As Long, CheckExist As Long
Dim sTotalDT As Long 'Tong con dich truyen cua moi ma
Dim sTotalCk As Long 'Tong con cong kham moi ma
Dim GTotalDT As Long 'Tong con dich truyen cua moi nhom
Dim GTotalCk As Long 'Tong con cong kham moi nhom
Dim TotalDT As Long 'Tong con dich truyen cua moi nhom
Dim TotalCk As Long 'Tong con cong kham moi nhom
Dim Dt As Long  'Tong tat ca dich truyen
Dim Ck As Long  'Tong tat ca cong kham
Sheets("Report").[A9:A10000].EntireRow.Delete
Arr = Sheets("DATA").Range("A3:Q" & Sheets("data").Range("A65536").End(3).Row)
ArrCode = Sheets("INF").Range("B3:C" & Sheets("INF").Range("B65536").End(3).Row)
ReDim Res(1 To UBound(Arr, 1) + 40, 1 To UBound(Arr, 2) + 1)
For i = 1 To UBound(ArrCode, 1)
    'Reset cac tong cua ma
    sTotalDT = 0
    sTotalCk = 0
    
    CheckExist = k      'Dung de kiem tra xem co ma thuoc nhom hay khong
    For j = 1 To UBound(Arr, 1)
        If UCase(Left(Arr(j, 4), 2)) = UCase(ArrCode(i, 1)) Then
            k = k + 1: Stt = Stt + 1
            Res(k, 1) = Stt
            For c = 1 To UBound(Arr, 2)
                Res(k, c + 1) = Arr(j, c)
            Next c
            sTotalDT = sTotalDT + Arr(j, 10)
            sTotalCk = sTotalCk + Arr(j, 15)
        End If
    Next j
'Ket thuc 1 ma thi them dong, Neu khong ton tai ma thi ko them
    If k > CheckExist Then
        k = k + 1
        Res(k, 2) = "Céng " & ArrCode(i, 1)
        Res(k, 5) = ArrCode(i, 1)
        Res(k, 11) = sTotalDT
        Res(k, 16) = sTotalCk
        Res(k, 18) = sTotalCk + sTotalDT
        GTotalDT = GTotalDT + sTotalDT
        GTotalCk = GTotalCk + sTotalCk
    End If
'Cong them dong khi ket thuc 1 nhom
    If i < UBound(ArrCode, 1) Then
        If ArrCode(i + 1, 2) > ArrCode(i, 2) Then
            k = k + 1
            Res(k, 2) = "Céng " & ArrCode(i, 2)
            Res(k, 11) = GTotalDT
            Res(k, 16) = GTotalCk
            Res(k, 18) = GTotalCk + GTotalDT
            
            k = k + 1
            Res(k, 2) = "Nhãm " & ArrCode(i + 1, 2)
            TotalDT = TotalDT + GTotalDT
            TotalCk = TotalCk + GTotalCk
            Ck = Ck + TotalCk
            Dt = Dt + TotalDT
            'Reset cac tong cua nhom
            GTotalDT = 0
            GTotalCk = 0
        End If
    Else
        k = k + 1
        Res(k, 2) = "Tæng céng I+II+III+IV+V+VI"
        Res(k, 11) = Dt
        Res(k, 16) = Ck
        Res(k, 18) = Ck + Dt
    End If
Next i
Sheets("Report").[A9].Resize(UBound(Res, 1), UBound(Res, 2)) = Res
[COLOR=#ff0000]With Application.Intersect([A9:S65536], Sheets("Report").Range("A9:A" & Sheets("Report").Range("A65536").End(3).Row + 2).SpecialCells(xlCellTypeBlanks).EntireRow)[/COLOR]
    .Interior.ColorIndex = 44
    .Font.Bold = True
    .Font.Italic = True
End With
End Sub
[COLOR=#0000ff]Cám ơn anh nhiều lắm
Có chổ bị lỗi ở dòng màu đỏ khi em cho sub vào 1 button anh ạ anh sửa giúp em với
Em cam ơn nhiều[/COLOR]
 
Upvote 0
1/ Tôi Copy Sub Report trong file bài trên (bỏ phần đầu và phần end sub) vào code button => Không có bất kỳ lỗi gì. Bạn hãy up file áp dụng lỗi lên đây xem nào.
2/ Bạn chưa phản hồi kết quả của file xem có đúng yêu cầu của bạn hay không?
 
Upvote 0
dhn46 đã viết:
1/ Tôi Copy Sub Report trong file bài trên (bỏ phần đầu và phần end sub) vào code button => Không có bất kỳ lỗi gì. Bạn hãy up file áp dụng lỗi lên đây xem nào.
2/ Bạn chưa phản hồi kết quả của file xem có đúng yêu cầu của bạn hay không?
Nhấp chuột vào đây để mở rộng...
1, Em xin lỗi em nhầm rồi anh ơi. Tại em vẽ cái button trên sheet rồi copy sub report của anh vào thế là bị lỗi. nó chỉ chạy trên form thôi.
2, Hoàn toàn đúng ngoài sức mong đợi của em.
Xin bày tỏ lòng cảm ơn sâu sắc của em đến anh.
cảm ơn anh dhn46 nhiều
 
Upvote 0
quoc nhat đã viết:
1, Em xin lỗi em nhầm rồi anh ơi. Tại em vẽ cái button trên sheet rồi copy sub report của anh vào thế là bị lỗi. nó chỉ chạy trên form thôi.
2, Hoàn toàn đúng ngoài sức mong đợi của em.
Xin bày tỏ lòng cảm ơn sâu sắc của em đến anh.
cảm ơn anh dhn46 nhiều
Nhấp chuột vào đây để mở rộng...
Vâng nếu Code chạy tốt đúng ý bạn là đạt yêu cầu rồi, trong Report của bạn còn 1 chút phần tổng công A+B+C... và phần chữ ký nữa, 2 cái đấy bạn tự áp dụng nhé => Khi ấy chắc chỉ mỗi việc in thôi không phải làm bằng tay bất cứ thao tác nào nữa
- Cái phần màu đỏ bên trên mình vẫn không hiểu tại sao lỗi. Mình đã Test cả với Form control + ActiveX control trên sheet của Ex 2003 + 2010 cũng không bị lỗi như bạn nói.

Chúc bạn thành công!
 
Upvote 0
dhn46 đã viết:
Vâng nếu Code chạy tốt đúng ý bạn là đạt yêu cầu rồi, trong Report của bạn còn 1 chút phần tổng công A+B+C... và phần chữ ký nữa, 2 cái đấy bạn tự áp dụng nhé => Khi ấy chắc chỉ mỗi việc in thôi không phải làm bằng tay bất cứ thao tác nào nữa
- Cái phần màu đỏ bên trên mình vẫn không hiểu tại sao lỗi. Mình đã Test cả với Form control + ActiveX control trên sheet của Ex 2003 + 2010 cũng không bị lỗi như bạn nói.

Chúc bạn thành công!
Nhấp chuột vào đây để mở rộng...
anh nhiệt tình quá!!!!!!!!!!
Chắc do em bấm button 2 lần mà bên sheet REPORT chưa kịp xóa hay sao ấy. Code vẫn chạy nhưng vẫn báo code lỗi đoạn code như bài trên em đã nói nhưng không sao đâu anh. em không giám làm phiền anh nhiều nhưng sau này có vấn đề gì thì cho anh giúp em anh nhé
cảm ơn anh
P/s : Em ít tuổi hơn anh nhiều mà anh dhn46 à
 
Lần chỉnh sửa cuối:
Upvote 0
Lần chỉnh sửa cuối:
Upvote 0
dhn46 đã viết:
1/ Tôi Copy Sub Report trong file bài trên (bỏ phần đầu và phần end sub) vào code button => Không có bất kỳ lỗi gì. Bạn hãy up file áp dụng lỗi lên đây xem nào.
2/ Bạn chưa phản hồi kết quả của file xem có đúng yêu cầu của bạn hay không?
Nhấp chuột vào đây để mở rộng...
Anh ơi em xin phép làm phiền anh một lần nữa.
Em xem giúp tại sao kết quả phần tổng cộng ( Tổng cộng I+II+III+IV+V+VI) sao lại không chính xác vậy anh?
Anh giúp em với
Em cảm ơn!
 
Upvote 0
quoc nhat đã viết:
Anh ơi em xin phép làm phiền anh một lần nữa.
Em xem giúp tại sao kết quả phần tổng cộng ( Tổng cộng I+II+III+IV+V+VI) sao lại không chính xác vậy anh?
Anh giúp em với
Em cảm ơn!
Nhấp chuột vào đây để mở rộng...
Bạn sửa lại toàn bộ Code như code phía dưới: (Code bổ sung cộng nhóm cuối cùng, fix lỗi tổng cộng)
Bạn chú ý code này đúng khi sheet INF được sắp xếp các nhóm theo thứ tự tăng dần.

Đôi điều góp ý với bạn:

1/ Nếu bạn có mục đích muốn học thì bạn nên hỏi từng phần vào các topic hoặc chủ đề liên quan có thể là "Giải đáp các thắc mắc về Code" không nên đưa nhiều vấn đề liên miên, liên tiếp không liên quan mọi người sẽ phải "chạy" theo bạn => không nên nhé. Còn nếu giúp bạn làm 1 công việc thì bạn nên đưa dữ liệu thật ngay từ đầu sẽ không mất thời gian để hiểu được ý của bạn và bạn sẽ rất nhanh có được phương án tốt nhất

2/ Khi có sự giúp đỡ bạn nên có đôi lời phản hồi, 1 lời cảm ơn cũng rất tốt và diễn đàn cũng đánh giá cao những người "biết" nhấn nút cảm ơn.

Thân!
Mã: 
Public Sub REPORT()
Dim Arr, Res, ArrCode
Dim i As Long, j As Long, k As Long, c As Long, Stt As Long, CheckExist As Long
Dim sTotalDT As Long 'Tong con dich truyen cua moi ma
Dim sTotalCk As Long 'Tong con cong kham moi ma
Dim GTotalDT As Long 'Tong con dich truyen cua moi nhom
Dim GTotalCk As Long 'Tong con cong kham moi nhom
Dim TotalDT As Long 'Tong dich truyen cua moi
Dim TotalCk As Long 'Tong cong kham moi


Sheets("Report").[A9:A10000].EntireRow.Delete
Arr = Sheets("DATA").Range("A3:Q" & Sheets("data").Range("A65536").End(3).Row)
ArrCode = Sheets("INF").Range("B3:C" & Sheets("INF").Range("B65536").End(3).Row)
ReDim Res(1 To UBound(Arr, 1) + 40, 1 To UBound(Arr, 2) + 1)
For i = 1 To UBound(ArrCode, 1)
    'Reset cac tong cua ma
    sTotalDT = 0
    sTotalCk = 0
    
    CheckExist = k      'Dung de kiem tra xem co ma thuoc nhom hay khong
    For j = 1 To UBound(Arr, 1)
        If UCase(Left(Arr(j, 4), 2)) = UCase(ArrCode(i, 1)) Then
            k = k + 1: Stt = Stt + 1
            Res(k, 1) = Stt
            For c = 1 To UBound(Arr, 2)
                Res(k, c + 1) = Arr(j, c)
            Next c
            sTotalDT = sTotalDT + Arr(j, 10)
            sTotalCk = sTotalCk + Arr(j, 15)
        End If
    Next j
'Ket thuc 1 ma thi them dong, Neu khong ton tai ma thi ko them
    If k > CheckExist Then
        k = k + 1
        Res(k, 2) = "Céng " & ArrCode(i, 1)
        Res(k, 5) = ArrCode(i, 1)
        Res(k, 11) = sTotalDT
        Res(k, 16) = sTotalCk
        Res(k, 18) = sTotalCk + sTotalDT
        GTotalDT = GTotalDT + sTotalDT
        GTotalCk = GTotalCk + sTotalCk
    End If
'Cong them dong khi ket thuc 1 nhom
    If i < UBound(ArrCode, 1) Then
        If ArrCode(i + 1, 2) > ArrCode(i, 2) Then
            k = k + 1
            Res(k, 2) = "Céng " & ArrCode(i, 2)
            Res(k, 11) = GTotalDT
            Res(k, 16) = GTotalCk
            Res(k, 18) = GTotalCk + GTotalDT
            
            k = k + 1
            Res(k, 2) = "Nhãm " & ArrCode(i + 1, 2)
            TotalDT = TotalDT + GTotalDT
            TotalCk = TotalCk + GTotalCk
            'Reset cac tong cua nhom
            GTotalDT = 0
            GTotalCk = 0
        End If
    Else
'Them cong nhom cuoi cung
        k = k + 1
        Res(k, 2) = "Céng " & ArrCode(i, 2)
        Res(k, 11) = GTotalDT
        Res(k, 16) = GTotalCk
        Res(k, 18) = GTotalCk + GTotalDT
        TotalDT = TotalDT + GTotalDT
        TotalCk = TotalCk + GTotalCk
'Them dong tong cong
        k = k + 1
        Res(k, 2) = "Tæng céng I+II+III+IV+V+VI"
        Res(k, 11) = TotalDT
        Res(k, 16) = TotalCk
        Res(k, 18) = TotalDT + TotalCk
    End If
Next i
Sheets("Report").[A9].Resize(UBound(Res, 1), UBound(Res, 2)) = Res
With Application.Intersect([A9:S65536], Sheets("Report").Range("A9:A" & Sheets("Report").Range("A65536").End(3).Row + 3).SpecialCells(xlCellTypeBlanks).EntireRow)
    .Interior.ColorIndex = 44
    .Font.Bold = True
    .Font.Italic = True
End With
End Sub
 
Upvote 0
dhn46 đã viết:
Đôi điều góp ý với bạn:

1/ Nếu bạn có mục đích muốn học thì bạn nên hỏi từng phần vào các topic hoặc chủ đề liên quan có thể là "Giải đáp các thắc mắc về Code" không nên đưa nhiều vấn đề liên miên, liên tiếp không liên quan mọi người sẽ phải "chạy" theo bạn => không nên nhé. Còn nếu giúp bạn làm 1 công việc thì bạn nên đưa dữ liệu thật ngay từ đầu sẽ không mất thời gian để hiểu được ý của bạn và bạn sẽ rất nhanh có được phương án tốt nhất

2/ Khi có sự giúp đỡ bạn nên có đôi lời phản hồi, 1 lời cảm ơn cũng rất tốt và diễn đàn cũng đánh giá cao những người "biết" nhấn nút cảm ơn.

Thân!
Nhấp chuột vào đây để mở rộng...
Dạ! Em sẽ rút kinh nghiệm trong việc hỏi bài lần sau.
anh đừng giận em vì lắm chuyện:
Anh cho em hỏi thêm mình phải định dạng font trên sheet report như thế nào để không bị lỗi font ở dòng "nhóm" , "Cộng" , "Tổng cộng I+III+IV+V+VI" hả anh?
Cảm ơn anh vì tất cả!
 
Lần chỉnh sửa cuối:
Upvote 0
dhn46 đã viết:
Bạn sửa lại toàn bộ Code như code phía dưới: (Code bổ sung cộng nhóm cuối cùng, fix lỗi tổng cộng)
Bạn chú ý code này đúng khi sheet INF được sắp xếp các nhóm theo thứ tự tăng dần.

Đôi điều góp ý với bạn:

1/ Nếu bạn có mục đích muốn học thì bạn nên hỏi từng phần vào các topic hoặc chủ đề liên quan có thể là "Giải đáp các thắc mắc về Code" không nên đưa nhiều vấn đề liên miên, liên tiếp không liên quan mọi người sẽ phải "chạy" theo bạn => không nên nhé. Còn nếu giúp bạn làm 1 công việc thì bạn nên đưa dữ liệu thật ngay từ đầu sẽ không mất thời gian để hiểu được ý của bạn và bạn sẽ rất nhanh có được phương án tốt nhất

2/ Khi có sự giúp đỡ bạn nên có đôi lời phản hồi, 1 lời cảm ơn cũng rất tốt và diễn đàn cũng đánh giá cao những người "biết" nhấn nút cảm ơn.

Thân!
Mã: 
Public Sub REPORT()
Dim Arr, Res, ArrCode
Dim i As Long, j As Long, k As Long, c As Long, Stt As Long, CheckExist As Long
Dim sTotalDT As Long 'Tong con dich truyen cua moi ma
Dim sTotalCk As Long 'Tong con cong kham moi ma
Dim GTotalDT As Long 'Tong con dich truyen cua moi nhom
Dim GTotalCk As Long 'Tong con cong kham moi nhom
Dim TotalDT As Long 'Tong dich truyen cua moi
Dim TotalCk As Long 'Tong cong kham moi


Sheets("Report").[A9:A10000].EntireRow.Delete
Arr = Sheets("DATA").Range("A3:Q" & Sheets("data").Range("A65536").End(3).Row)
ArrCode = Sheets("INF").Range("B3:C" & Sheets("INF").Range("B65536").End(3).Row)
ReDim Res(1 To UBound(Arr, 1) + 40, 1 To UBound(Arr, 2) + 1)
For i = 1 To UBound(ArrCode, 1)
    'Reset cac tong cua ma
    sTotalDT = 0
    sTotalCk = 0
    
    CheckExist = k      'Dung de kiem tra xem co ma thuoc nhom hay khong
    For j = 1 To UBound(Arr, 1)
        If UCase(Left(Arr(j, 4), 2)) = UCase(ArrCode(i, 1)) Then
            k = k + 1: Stt = Stt + 1
            Res(k, 1) = Stt
            For c = 1 To UBound(Arr, 2)
                Res(k, c + 1) = Arr(j, c)
            Next c
            sTotalDT = sTotalDT + Arr(j, 10)
            sTotalCk = sTotalCk + Arr(j, 15)
        End If
    Next j
'Ket thuc 1 ma thi them dong, Neu khong ton tai ma thi ko them
    If k > CheckExist Then
        k = k + 1
        Res(k, 2) = "Céng " & ArrCode(i, 1)
        Res(k, 5) = ArrCode(i, 1)
        Res(k, 11) = sTotalDT
        Res(k, 16) = sTotalCk
        Res(k, 18) = sTotalCk + sTotalDT
        GTotalDT = GTotalDT + sTotalDT
        GTotalCk = GTotalCk + sTotalCk
    End If
'Cong them dong khi ket thuc 1 nhom
    If i < UBound(ArrCode, 1) Then
        If ArrCode(i + 1, 2) > ArrCode(i, 2) Then
            k = k + 1
            Res(k, 2) = "Céng " & ArrCode(i, 2)
            Res(k, 11) = GTotalDT
            Res(k, 16) = GTotalCk
            Res(k, 18) = GTotalCk + GTotalDT
            
            k = k + 1
            Res(k, 2) = "Nhãm " & ArrCode(i + 1, 2)
            TotalDT = TotalDT + GTotalDT
            TotalCk = TotalCk + GTotalCk
            'Reset cac tong cua nhom
            GTotalDT = 0
            GTotalCk = 0
        End If
    Else
'Them cong nhom cuoi cung
        k = k + 1
        Res(k, 2) = "Céng " & ArrCode(i, 2)
        Res(k, 11) = GTotalDT
        Res(k, 16) = GTotalCk
        Res(k, 18) = GTotalCk + GTotalDT
        TotalDT = TotalDT + GTotalDT
        TotalCk = TotalCk + GTotalCk
'Them dong tong cong
        k = k + 1
        Res(k, 2) = "Tæng céng I+II+III+IV+V+VI"
        Res(k, 11) = TotalDT
        Res(k, 16) = TotalCk
        Res(k, 18) = TotalDT + TotalCk
    End If
Next i
Sheets("Report").[A9].Resize(UBound(Res, 1), UBound(Res, 2)) = Res
With Application.Intersect([A9:S65536], Sheets("Report").Range("A9:A" & Sheets("Report").Range("A65536").End(3).Row + 3).SpecialCells(xlCellTypeBlanks).EntireRow)
    .Interior.ColorIndex = 44
    .Font.Bold = True
    .Font.Italic = True
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Lâu lắm mới tìm xem lại Topic.
Bây giờ muốn Stt lặp lại khi kết thúc một nhóm thì mình làm thế nào ạ
Anh dhn46 ơi giúp em lần nữa với ạ.
Em cảm ơn anh
 
Upvote 0
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.

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

L
File Excel nặng chưa tìm được lý do ở đâu . Mong các bác hỗ trợ ! (6 người xem)
Trả lời
2
Đọc
17
lưu tuấn dũng
L
J
Xử lý các file Excel bị nặng sau nhiều năm sử dụng (3 người xem)
Trả lời
12
Đọc
2K
lưu tuấn dũng
L
Nguyễn Duy Tuân
Hàm BS COMBINLIST Liệt kê các giá trị tổ hợp, chỉnh hợp, chỉnh hợp không lặp | Add-in A-Tools v10 (3 người xem)
    • Yêu thích
    • Thích
Trả lời
13
Đọc
1K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
hongphuong1997
Nên sử dụng Chatgpt hay Copilot (1 người xem)
    • Yêu thích
Trả lời
11
Đọc
217
befaint
befaint
H
Tổng hợp Công Nợ theo CT (1 người xem)
Trả lời
5
Đọc
43
le_vis
L
D
XIN HỖ TRỢ VỀ FILE EXCEL TỔNG HỢP ĐIỂM THI ĐUA (3 người xem)
Trả lời
0
Đọc
24
DươngH193
D
L
Xin file lịch báo giảng tự động
Trả lời
2
Đọc
79
linedraw84
L
H
Xin File Theo dõi công nợ
Trả lời
0
Đọc
49
HangktGTN
H
2
  • Question Question
Hỏi cách in phiếu điều tra PCGD-XMC từ file dữ liệu mẫu xuất ra từ hệ thống PCGD-XMC của Bộ GD
    • Thích
Trả lời
16
Đọc
993
linedraw84
L
N
Tạo file Excel dùng VBA để lấy và nối dữ liệu từ các files excel
Trả lời
39
Đọc
6K
hungnv_thct2026
H
S
Power BI. Một quá trình đòi hỏi sự kiên nhẫn. (1 người xem)
Trả lời
4
Đọc
200
SteveNguyen1991
S
SA_DQ
  • Question Question
Bài tập VBA cho những người rỗi. . . đủ thứ!
    • Ngạc nhiên
    • Cười
    • Yêu thích
Trả lời
21
Đọc
738
Phuocam
Phuocam
H
Giúp mình ghép nhiều file thành một file.
Trả lời
9
Đọc
349
Hoàng Tuấn 868
H
H
  • Question Question
Dò tìm giá trị từ bảng khác theo cột
Trả lời
5
Đọc
109
ptm0412
ptm0412
L
Cách bật/tắt đèn led thứ 3 trên bàn phím cơ
Trả lời
1
Đọc
69
HUONGHCKT
H
C
Không thể group cột trong excel
Trả lời
10
Đọc
12K
ptm0412
ptm0412
A
  • Question Question
Em nhờ anh/chị/em/chú/bác giúp em viết code tổng hợp dữ liệu. em tính công thức nó nặng quá. em cám ơn
Trả lời
14
Đọc
995
Hoàng Tuấn 868
H
H
Xin giúp đỡ về phổ cập (2 người xem)
Trả lời
5
Đọc
1K
tranvanky8111967
T
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (3 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
420
Đọc
52K
maingoctu89
M
P
Xin giúp sửa code VBA tổng hợp sản lượng theo format file FCS đổ từ hệ thống ERP.
Trả lời
14
Đọc
322
DeTong
D
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

Thời gian đếm ngược.

000
Ngày
00
Giờ
00
phút
00
giây
Thân mời tham dự sự kiện sinh nhật GPE 2025
Back
Top Bottom