Code Tính các mã hàng trùng nhau theo điều kiện

Liên hệ QC
T

tanthanh94

Thành viên mới
Tham gia
24/8/14
Bài viết
46
Được thích
3
Mình mượn code trên diễn đàn về chỉnh sữa lại
Mình muốn code trả về kết quả trực tiếp tại A3 mà không cần bổ sung thêm phần code màu đỏ
Mã: 
Private Sub Worksheet_Activate()
Dim I As Long, K As Long, Darr()
Dim Sarr(), Temp(), Col As Long, J As Long, M As Long
Col = 8
Sarr = Sheet1.Range("B3", Sheet1.[B65536].End(3)).Resize(, Col).Value
ReDim Darr(1 To UBound(Sarr), 1 To Col)
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(Sarr)
        If Not .exists(Sarr(I, 1)) Then
            K = K + 1
            .Add Sarr(I, 1), K
            For J = 1 To Col - 1
               Darr(K, J) = Sarr(I, J)
            Next
            Darr(K, Col) = Sarr(I, Col)
        Else
            Darr(.Item(Sarr(I, 1)), Col) = _
            Darr(.Item(Sarr(I, 1)), Col) + Sarr(I, Col)
        End If
    Next
End With
Sheet2.Range("A3:I65000").ClearContents
Sheet2.[B3].Resize(K, Col) = Darr
[COLOR=#ff0000]Sarr = Sheet2.Range("B3", Sheet2.[B65536].End(3)).Resize(, Col).Value[/COLOR]
[COLOR=#ff0000] For I = 1 To UBound(Sarr)[/COLOR]
[COLOR=#ff0000]    M = M + 1[/COLOR]
[COLOR=#ff0000]     For J = 1 To Col[/COLOR]
[COLOR=#ff0000]        Darr(M, 1) = M[/COLOR]
[COLOR=#ff0000]        Darr(M, 2) = Sarr(I, 1)[/COLOR]
[COLOR=#ff0000]        Darr(M, 3) = Sarr(I, 2)[/COLOR]
[COLOR=#ff0000]        Darr(M, 4) = Sarr(I, 7)[/COLOR]
[COLOR=#ff0000]        Darr(M, 5) = Sarr(I, 8) / Sarr(I, 4) / Sarr(I, 5)[/COLOR]
[COLOR=#ff0000]        Next[/COLOR]
[COLOR=#ff0000]        Next[/COLOR]
[COLOR=#ff0000]        Sheet2.[K3].Resize(M, 5) = Darr[/COLOR]
End Sub
 

File đính kèm

Không ai giúp đành phải đọc bài khác chờ đợi thôi.
 
tanthanh94 đã viết:
Mình mượn code trên diễn đàn về chỉnh sữa lại
Mình muốn code trả về kết quả trực tiếp tại A3 mà không cần bổ sung thêm phần code màu đỏ
Mã: 
Private Sub Worksheet_Activate()
Dim I As Long, K As Long, Darr()
Dim Sarr(), Temp(), Col As Long, J As Long, M As Long
Col = 8
Sarr = Sheet1.Range("B3", Sheet1.[B65536].End(3)).Resize(, Col).Value
ReDim Darr(1 To UBound(Sarr), 1 To Col)
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(Sarr)
        If Not .exists(Sarr(I, 1)) Then
            K = K + 1
            .Add Sarr(I, 1), K
            For J = 1 To Col - 1
               Darr(K, J) = Sarr(I, J)
            Next
            Darr(K, Col) = Sarr(I, Col)
        Else
            Darr(.Item(Sarr(I, 1)), Col) = _
            Darr(.Item(Sarr(I, 1)), Col) + Sarr(I, Col)
        End If
    Next
End With
Sheet2.Range("A3:I65000").ClearContents
Sheet2.[B3].Resize(K, Col) = Darr
[COLOR=#ff0000]Sarr = Sheet2.Range("B3", Sheet2.[B65536].End(3)).Resize(, Col).Value[/COLOR]
[COLOR=#ff0000] For I = 1 To UBound(Sarr)[/COLOR]
[COLOR=#ff0000]    M = M + 1[/COLOR]
[COLOR=#ff0000]     For J = 1 To Col[/COLOR]
[COLOR=#ff0000]        Darr(M, 1) = M[/COLOR]
[COLOR=#ff0000]        Darr(M, 2) = Sarr(I, 1)[/COLOR]
[COLOR=#ff0000]        Darr(M, 3) = Sarr(I, 2)[/COLOR]
[COLOR=#ff0000]        Darr(M, 4) = Sarr(I, 7)[/COLOR]
[COLOR=#ff0000]        Darr(M, 5) = Sarr(I, 8) / Sarr(I, 4) / Sarr(I, 5)[/COLOR]
[COLOR=#ff0000]        Next[/COLOR]
[COLOR=#ff0000]        Next[/COLOR]
[COLOR=#ff0000]        Sheet2.[K3].Resize(M, 5) = Darr[/COLOR]
End Sub
Nhấp chuột vào đây để mở rộng...
Đề tài không đầu không cuối. Bạn nên nói rõ là Code bạn sưu tầm được trên diễn đàn là để làm việc gì? (Ít ra là nêu ra đề bài rồi áp dụng Code trên để giải quyết).
 
tanthanh94 đã viết:
Mình mượn code trên diễn đàn về chỉnh sữa lại
Mình muốn code trả về kết quả trực tiếp tại A3 mà không cần bổ sung thêm phần code màu đỏ
Mã: 
Private Sub Worksheet_Activate()
Dim I As Long, K As Long, Darr()
Dim Sarr(), Temp(), Col As Long, J As Long, M As Long
Col = 8
Sarr = Sheet1.Range("B3", Sheet1.[B65536].End(3)).Resize(, Col).Value
ReDim Darr(1 To UBound(Sarr), 1 To Col)
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(Sarr)
        If Not .exists(Sarr(I, 1)) Then
            K = K + 1
            .Add Sarr(I, 1), K
            For J = 1 To Col - 1
               Darr(K, J) = Sarr(I, J)
            Next
            Darr(K, Col) = Sarr(I, Col)
        Else
            Darr(.Item(Sarr(I, 1)), Col) = _
            Darr(.Item(Sarr(I, 1)), Col) + Sarr(I, Col)
        End If
    Next
End With
Sheet2.Range("A3:I65000").ClearContents
Sheet2.[B3].Resize(K, Col) = Darr
[COLOR=#ff0000]Sarr = Sheet2.Range("B3", Sheet2.[B65536].End(3)).Resize(, Col).Value[/COLOR]
[COLOR=#ff0000] For I = 1 To UBound(Sarr)[/COLOR]
[COLOR=#ff0000]    M = M + 1[/COLOR]
[COLOR=#ff0000]     For J = 1 To Col[/COLOR]
[COLOR=#ff0000]        Darr(M, 1) = M[/COLOR]
[COLOR=#ff0000]        Darr(M, 2) = Sarr(I, 1)[/COLOR]
[COLOR=#ff0000]        Darr(M, 3) = Sarr(I, 2)[/COLOR]
[COLOR=#ff0000]        Darr(M, 4) = Sarr(I, 7)[/COLOR]
[COLOR=#ff0000]        Darr(M, 5) = Sarr(I, 8) / Sarr(I, 4) / Sarr(I, 5)[/COLOR]
[COLOR=#ff0000]        Next[/COLOR]
[COLOR=#ff0000]        Next[/COLOR]
[COLOR=#ff0000]        Sheet2.[K3].Resize(M, 5) = Darr[/COLOR]
End Sub
Nhấp chuột vào đây để mở rộng...

Dồn thằng dưới (Màu đỏ) lên trên luôn phải không?
PHP: 
Private Sub Worksheet_Activate()
Dim sArr(), dArr(), I As Long, K As Long, J As Long, Tem As String, Num As Double
sArr = Sheet1.Range("A3", Sheet1.[B65536].End(3)).Resize(, 9).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 15)
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 2)
        Num = sArr(I, 9) / sArr(I, 5) / sArr(I, 6)
        If Not .Exists(Tem) Then
            K = K + 1
            .Add Tem, K
            For J = 1 To 9
               dArr(K, J) = sArr(I, J)
            Next
            dArr(K, 11) = K
            dArr(K, 12) = sArr(I, 2)
            dArr(K, 13) = sArr(I, 3)
            dArr(K, 14) = sArr(I, 8)
            dArr(K, 15) = Num
        Else
            dArr(.Item(Tem), 9) = dArr(.Item(Tem), 9) + sArr(I, 9)
            dArr(.Item(Tem), 15) = dArr(.Item(Tem), 15) + Num
        End If
    Next
End With
With Sheet2
    .Range("A3:O1000").ClearContents
    If K Then .[A3].Resize(K, 15) = dArr
End With
End Sub
 
Ba Tê đã viết:
Dồn thằng dưới (Màu đỏ) lên trên luôn phải không?
PHP: 
Private Sub Worksheet_Activate()
Dim sArr(), dArr(), I As Long, K As Long, J As Long, Tem As String, Num As Double
sArr = Sheet1.Range("A3", Sheet1.[B65536].End(3)).Resize(, 9).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 15)
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 2)
        Num = sArr(I, 9) / sArr(I, 5) / sArr(I, 6)
        If Not .Exists(Tem) Then
            K = K + 1
            .Add Tem, K
            For J = 1 To 9
               dArr(K, J) = sArr(I, J)
            Next
            dArr(K, 11) = K
            dArr(K, 12) = sArr(I, 2)
            dArr(K, 13) = sArr(I, 3)
            dArr(K, 14) = sArr(I, 8)
            dArr(K, 15) = Num
        Else
            dArr(.Item(Tem), 9) = dArr(.Item(Tem), 9) + sArr(I, 9)
            dArr(.Item(Tem), 15) = dArr(.Item(Tem), 15) + Num
        End If
    Next
End With
With Sheet2
    .Range("A3:O1000").ClearContents
    If K Then .[A3].Resize(K, 15) = dArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Em muốn kết quả tính từ sheet 1 qua sheet 2 ra giống cột K:O luôn không cần dữ liệu cột A:I
Nhưng kết quả cột K:O nằm tại vị trí cột A
File của em có nội dụng như sau
Tính tổng các mà hàng trùng nhau sau đó chia cho cột F và chia tiếp cột E .
Cám ơn anh đã bỏ thời gian chỉ giúp.
 
Lần chỉnh sửa cuối:
tanthanh94 đã viết:
Em muốn kết quả tính từ sheet 1 qua sheet 2 ra giống cột K:O luôn không cần dữ liệu cột A:I
Nhưng kết quả cột K:O nằm tại vị trí cột A
File của em có nội dụng như sau
Tính tổng các mà hàng trùng nhau sau đó chia cho cột F và chia tiếp cột E .
Cám ơn anh đã bỏ thời gian chỉ giúp.
Nhấp chuột vào đây để mở rộng...

Đọc câu này mà hiểu được ý bạn muốn chắc là "thiên tài"
Mình muốn code trả về kết quả trực tiếp tại A3 mà không cần bổ sung thêm phần code màu đỏ
Nhấp chuột vào đây để mở rộng...
PHP: 
Private Sub Worksheet_Activate()
Dim sArr(), dArr(), I As Long, K As Long, J As Long, Tem As String, Num As Double
sArr = Sheet1.Range("A3", Sheet1.[B65536].End(3)).Resize(, 9).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 2)
        Num = sArr(I, 9) / sArr(I, 5) / sArr(I, 6)
        If Not .Exists(Tem) Then
            K = K + 1
            .Add Tem, K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 3)
            dArr(K, 4) = sArr(I, 8)
            dArr(K, 5) = Num
        Else
            dArr(.Item(Tem), 5) = dArr(.Item(Tem), 5) + Num
        End If
    Next
End With
With Sheet2
    .Range("A3:E1000").ClearContents
    If K Then .[A3].Resize(K, 5) = dArr
End With
End Sub
 
Ba Tê đã viết:
Đọc câu này mà hiểu được ý bạn muốn chắc là "thiên tài"

PHP: 
Private Sub Worksheet_Activate()
Dim sArr(), dArr(), I As Long, K As Long, J As Long, Tem As String, Num As Double
sArr = Sheet1.Range("A3", Sheet1.[B65536].End(3)).Resize(, 9).Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
With CreateObject("Scripting.Dictionary")
    For I = 1 To UBound(sArr, 1)
        Tem = sArr(I, 2)
        Num = sArr(I, 9) / sArr(I, 5) / sArr(I, 6)
        If Not .Exists(Tem) Then
            K = K + 1
            .Add Tem, K
            dArr(K, 1) = K
            dArr(K, 2) = sArr(I, 2)
            dArr(K, 3) = sArr(I, 3)
            dArr(K, 4) = sArr(I, 8)
            dArr(K, 5) = Num
        Else
            dArr(.Item(Tem), 5) = dArr(.Item(Tem), 5) + Num
        End If
    Next
End With
With Sheet2
    .Range("A3:E1000").ClearContents
    If K Then .[A3].Resize(K, 5) = dArr
End With
End Sub
Nhấp chuột vào đây để mở rộng...
Cám ơn anh rất nhiều.
 
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

ongke0711
  • Question Question
Trộn dữ liệu từ Excel sang Word mở rộng (phiên bản ongke0711)
    • Thích
    • Yêu thích
    • Cảm ơn
11 12 13
Trả lời
259
Đọc
27K
vc_đi chơi
vc_đi chơi
Thanh271188
Tìm giá trị xuất hiện bất kì (không phải giá trị đầu, cuối) trong excel
Trả lời
2
Đọc
28
Thanh271188
Thanh271188
L
[Help] tự động lấy dữ liệu cổ phiếu từ vietstock về file excel
    • Thích
Trả lời
3
Đọc
732
ketoan113
K
N
Tách chuỗi và tìm kiếm theo dữ liệu gần đúng trong chuỗi ký tự
Trả lời
8
Đọc
135
Ngocminh19
N
Mr.hieudoanxd
  • Question Question
[Cần hướng dẫn] Về lập trình Viết Function với Settimer và Killtimer
    • Thích
Trả lời
8
Đọc
256
nguyendang95
N
P
Các Bác cho e hỏi làm thế nào để ẩn công thức trên GOOGLE SHEET với ạ?
2
Trả lời
21
Đọc
18K
học excel googlesheet
học excel googlesheet
Emyeuexcel
  • Question Question
Code VBA mở nhiều file, value các sheet, lưu và đóng file
Trả lời
3
Đọc
65
Emyeuexcel
Emyeuexcel
V
Cho 2 biến - kết quả trả về giá trị của hàng đầu tiên
    • Chấp nhận
Trả lời
5
Đọc
98
Duy Tùng 9x
Duy Tùng 9x
D
Giúp đỡ thống kê dữ liệu theo điều kiện
Trả lời
8
Đọc
189
HieuCD
H
bachloc1212
Đưa Text từ các dòng khác nhau về chung 1 dòng
Trả lời
10
Đọc
219
VetMini
V
N
Sửa lỗi code vba khi chạy cho ra kết quả không đúng
Trả lời
6
Đọc
156
VetMini
V
Ha Manh-LD
  • Question Question
Lấy dữ liệu từ file csv
Trả lời
1
Đọc
112
ptm0412
ptm0412
T
Nhờ hỗ trợ hàm SUMIF không phân biệt được các ký tự "0" trước một số trong chuỗi
Trả lời
2
Đọc
118
VetMini
V
LuuAnh980
Add in tạo QR code miễn phí.
Trả lời
13
Đọc
423
LuuAnh980
LuuAnh980
HeSanbi
  • Đã giải quyết
VBA Nâng cao: Hướng dẫn tạo biểu thức tìm kiếm với Regular Expression
    • Thích
    • Yêu thích
Trả lời
9
Đọc
878
HeSanbi
HeSanbi
Tienvinh191
  • Question Question
Nhờ viết Code lấy dữ liệu tờ khai hải quan vào bảng tổng hợp
2
Trả lời
28
Đọc
3K
quyenpv
quyenpv
F
Hiển thị text trong Gantt chart (Google sheets)
Trả lời
0
Đọc
58
FATA11
F
Maika8008
  • Đã giải quyết
[Chia sẻ] Dùng VBA trộn dữ liệu Excel sang file Word mẫu (tương tự chức năng Mail Merge)
    • Thích
    • Yêu thích
    • Cảm ơn
25 26 27
Trả lời
522
Đọc
50K
Manhhung90
Manhhung90
C
Trách nhiệm pháp lý của chi nhánh doanh nghiệp Việt Nam tại nước ngoài với Công ty tại Việt Nam
Trả lời
5
Đọc
221
VetMini
V
C
  • Question Question
import data từ excel lên google sheet
Trả lời
5
Đọc
630
SonBDND
S
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
Chúc mừng năm mới Ất Tỵ 2025
Back
Top Bottom