Giúp code Cộng dộn Số lượng Và Thành tiền theo tên hàng (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)
minhtuan55

minhtuan55

Thành viên bị đình chỉ hoạt động
Thành viên bị đình chỉ hoạt động
Tham gia
23/3/16
Bài viết
705
Được thích
52
Chào cả nhà GPE !
Em cần 1 đoạn code để tách tên hàng và sau khi tách thì cộng dồn Số lượng và Thành Tiền lại . em đã tự nghĩ viết mãi không ra nay nhờ mọi người giúp đở để học hỏi. Xin chân thành cảm ơn !
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
minhtuan55 đã viết:
Chào cả nhà GPE !
Em cần 1 đoạn code để tách tên hàng và sau khi tách thì cộng dồn Số lượng và Thành Tiền lại . em đã tự nghĩ viết mãi không ra nay nhờ mọi người giúp đở để học hỏi. Xin chân thành cảm ơn !
Nhấp chuột vào đây để mở rộng...
1 cách:
PHP: 
Option Explicit
Sub TH()
    Application.ScreenUpdating = False
    abc
    abc2
    Application.ScreenUpdating = True
End Sub
Sub abc()
    Dim a, b, c(1 To 10000, 1 To 1), i, j, k, LR
    a = [B6:b8].Value
    For i = 1 To UBound(a, 1)
        b = Split(a(i, 1), ";")
        For j = LBound(b) To UBound(b)
            k = k + 1: c(k, 1) = b(j)
        Next j
    Next i
    [C10].Resize(k) = c
    Range("C10:C1000").SpecialCells(4).EntireRow.Delete
    LR = Range("C" & Rows.Count).End(xlUp).Row
    For i = 10 To LR
        Range("F" & i - 4) = Split(Range("C" & i), "*")(0)
        Range("G" & i - 4) = Split(Range("C" & i), "*")(1)
        Range("H" & i - 4) = Split(Range("C" & i), "*")(2)
    Next i
    Columns(3).ClearContents
    For i = 6 To Range("F" & Rows.Count).End(xlUp).Row
        Cells(i, 9) = Cells(i, 8) * Cells(i, 7)
    Next

End Sub
Sub abc2()
    Dim i As Long, k As Long, T As Long
    Dim InputData(), OutputData()
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.dictionary")
    InputData = Sheet1.Range("F6:I" & Sheet1.[F65000].End(xlUp).Row).Value
    ReDim OutputData(1 To UBound(InputData), 1 To 4)
    For i = 1 To UBound(InputData)
        If Not Dic.exists(InputData(i, 1)) Then
            k = k + 1
            Dic(InputData(i, 1)) = k
            OutputData(k, 1) = InputData(i, 1): OutputData(k, 2) = InputData(i, 2): OutputData(k, 4) = InputData(i, 4)
        Else
            T = Dic.Item(InputData(i, 1))
            OutputData(T, 2) = OutputData(T, 2) + InputData(i, 2)
            OutputData(T, 4) = OutputData(T, 4) + InputData(i, 4)
            OutputData(T, 3) = OutputData(T, 4)
        End If
    Next
    Sheet1.Range("F6:I1000").ClearContents
    Sheet1.Range("F6").Resize(k, 3) = OutputData
    Set Dic = Nothing
End Sub
 

File đính kèm

Upvote 0
phulien1902 đã viết:
1 cách:
PHP: 
Option Explicit
Sub TH()
    Application.ScreenUpdating = False
    abc
    abc2
    Application.ScreenUpdating = True
End Sub
Sub abc()
    Dim a, b, c(1 To 10000, 1 To 1), i, j, k, LR
    a = [B6:b8].Value
    For i = 1 To UBound(a, 1)
        b = Split(a(i, 1), ";")
        For j = LBound(b) To UBound(b)
            k = k + 1: c(k, 1) = b(j)
        Next j
    Next i
    [C10].Resize(k) = c
    Range("C10:C1000").SpecialCells(4).EntireRow.Delete
    LR = Range("C" & Rows.Count).End(xlUp).Row
    For i = 10 To LR
        Range("F" & i - 4) = Split(Range("C" & i), "*")(0)
        Range("G" & i - 4) = Split(Range("C" & i), "*")(1)
        Range("H" & i - 4) = Split(Range("C" & i), "*")(2)
    Next i
    Columns(3).ClearContents
    For i = 6 To Range("F" & Rows.Count).End(xlUp).Row
        Cells(i, 9) = Cells(i, 8) * Cells(i, 7)
    Next

End Sub
Sub abc2()
    Dim i As Long, k As Long, T As Long
    Dim InputData(), OutputData()
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.dictionary")
    InputData = Sheet1.Range("F6:I" & Sheet1.[F65000].End(xlUp).Row).Value
    ReDim OutputData(1 To UBound(InputData), 1 To 4)
    For i = 1 To UBound(InputData)
        If Not Dic.exists(InputData(i, 1)) Then
            k = k + 1
            Dic(InputData(i, 1)) = k
            OutputData(k, 1) = InputData(i, 1): OutputData(k, 2) = InputData(i, 2): OutputData(k, 4) = InputData(i, 4)
        Else
            T = Dic.Item(InputData(i, 1))
            OutputData(T, 2) = OutputData(T, 2) + InputData(i, 2)
            OutputData(T, 4) = OutputData(T, 4) + InputData(i, 4)
            OutputData(T, 3) = OutputData(T, 4)
        End If
    Next
    Sheet1.Range("F6:I1000").ClearContents
    Sheet1.Range("F6").Resize(k, 3) = OutputData
    Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...


Code anh rất OK. Em xin cảm ơn . em cũng hiểu code anh là nó tách ra trước sau đó mới cộng dồn lại. Anh có cách nào không tách ra mà cộng dồn được không. Vì em sợ Ví dụ chuổi có 5000 dòng mã mổi dòng có 100 thực đơn vậy số dòng tách ra = 5000 * 100 = 500.000 dòng vậy Excel 2003 nó không đủ dòng để chứa. Anh có cách nào khắc phục không ( excel 2010 và 2007 em không thích vì có 1 số code nó không chạy được em tẩy chay luôn rồi)
 
Upvote 0
minhtuan55 đã viết:
Code anh rất OK. Em xin cảm ơn . em cũng hiểu code anh là nó tách ra trước sau đó mới cộng dồn lại. Anh có cách nào không tách ra mà cộng dồn được không. Vì em sợ Ví dụ chuổi có 5000 dòng mã mổi dòng có 100 thực đơn vậy số dòng tách ra = 5000 * 100 = 500.000 dòng vậy Excel 2003 nó không đủ dòng để chứa. Anh có cách nào khắc phục không ( excel 2010 và 2007 em không thích vì có 1 số code nó không chạy được em tẩy chay luôn rồi)
Nhấp chuột vào đây để mở rộng...
Bạn cố gắng chờ đợi các thành viên khác nhé.
 
Upvote 0
minhtuan55 đã viết:
Chào cả nhà GPE !
Em cần 1 đoạn code để tách tên hàng và sau khi tách thì cộng dồn Số lượng và Thành Tiền lại . em đã tự nghĩ viết mãi không ra nay nhờ mọi người giúp đở để học hỏi. Xin chân thành cảm ơn !
Nhấp chuột vào đây để mở rộng...
Chạy thử code
Mã: 
Sub GPE()
  Dim Dic As Object, dArr As Variant, Arr As Variant, tmp As Variant, S As Variant
  Dim i As Long, j As Integer, k As Long, ik As Long, key As String
  Set Dic = CreateObject("Scripting.dictionary")
  dArr = Range("B6", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim Arr(1 To UBound(dArr), 1 To 3)
  For i = 1 To UBound(dArr)
      tmp = Split(dArr(i, 1), ";")
      For j = LBound(tmp) To UBound(tmp)
          S = Split(tmp(j), "*")
          If UBound(S) = 2 Then
              Key = S(0)
              If Not Dic.exists(Key) Then
                  k = k + 1
                  Dic.Add Key, k
                  Arr(k, 1) = Key
              End If
              ik = Dic.Item(Key)
              Arr(ik, 2) = Arr(ik, 2) + CDbl(S(1))
              Arr(ik, 3) = Arr(ik, 3) + CDbl(S(2))
          End If
      Next j
  Next i
  i = Range("F" & Rows.Count).End(xlUp).Row
  If i > 5 Then Range("F6:H" & i).ClearContents
  Range("F6:H6").Resize(k) = Arr
End Sub
 
Upvote 0
HieuCD đã viết:
Chạy thử code
Mã: 
Sub GPE()
  Dim Dic As Object, dArr As Variant, Arr As Variant, tmp As Variant, S As Variant
  Dim i As Long, j As Integer, k As Long, ik As Long, key As String
  Set Dic = CreateObject("Scripting.dictionary")
  dArr = Range("B6", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim Arr(1 To UBound(dArr), 1 To 3)
  For i = 1 To UBound(dArr)
      tmp = Split(dArr(i, 1), ";")
      For j = LBound(tmp) To UBound(tmp)
          S = Split(tmp(j), "*")
          If UBound(S) = 2 Then
              Key = S(0)
              If Not Dic.exists(Key) Then
                  k = k + 1
                  Dic.Add Key, k
                  Arr(k, 1) = Key
              End If
              ik = Dic.Item(Key)
              Arr(ik, 2) = Arr(ik, 2) + CDbl(S(1))
              Arr(ik, 3) = Arr(ik, 3) + CDbl(S(2))
          End If
      Next j
  Next i
  i = Range("F" & Rows.Count).End(xlUp).Row
  If i > 5 Then Range("F6:H" & i).ClearContents
  Range("F6:H6").Resize(k) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Dường như kết quả(Thành tiền) có khác so với đáp án của chủ Topic bác HieuCD à.
 
Upvote 0
phulien1902 đã viết:
Dường như kết quả(Thành tiền) có khác so với đáp án của chủ Topic bác HieuCD à.
Nhấp chuột vào đây để mở rộng...
Mình quên nhân cho sản lượng
Arr(ik, 3) = Arr(ik, 3) + CDbl(S(2))
Chỉnh lại
Arr(ik, 3) = Arr(ik, 3) + CDbl(S(1)) * CDbl(S(2))
Mã: 
Sub GPE()
  Dim Dic As Object, dArr As Variant, Arr As Variant, tmp As Variant, S As Variant
  Dim i As Long, j As Integer, k As Long, ik As Long, key As String
  Set Dic = CreateObject("Scripting.dictionary")
  dArr = Range("B6", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim Arr(1 To UBound(dArr), 1 To 3)
  For i = 1 To UBound(dArr)
      tmp = Split(dArr(i, 1), ";")
      For j = LBound(tmp) To UBound(tmp)
          S = Split(tmp(j), "*")
          If UBound(S) = 2 Then
              key = S(0)
              If Not Dic.exists(key) Then
                  k = k + 1
                  Dic.Add key, k
                  Arr(k, 1) = key
              End If
              ik = Dic.Item(key)
              Arr(ik, 2) = Arr(ik, 2) + CDbl(S(1))
              Arr(ik, 3) = Arr(ik, 3) + CDbl(S(1)) * CDbl(S(2))
          End If
      Next j
  Next i
  i = Range("F" & Rows.Count).End(xlUp).Row
  If i > 5 Then Range("F6:H" & i).ClearContents
  Range("F6:H6").Resize(k) = Arr
End Sub
 
Upvote 0
phulien1902 đã viết:
1 cách:
PHP: 
Option Explicit
Sub TH()
    Application.ScreenUpdating = False
    abc
    abc2
    Application.ScreenUpdating = True
End Sub
Sub abc()
    Dim a, b, c(1 To 10000, 1 To 1), i, j, k, LR
    a = [B6:b8].Value
    For i = 1 To UBound(a, 1)
        b = Split(a(i, 1), ";")
        For j = LBound(b) To UBound(b)
            k = k + 1: c(k, 1) = b(j)
        Next j
    Next i
    [C10].Resize(k) = c
    Range("C10:C1000").SpecialCells(4).EntireRow.Delete
    LR = Range("C" & Rows.Count).End(xlUp).Row
    For i = 10 To LR
        Range("F" & i - 4) = Split(Range("C" & i), "*")(0)
        Range("G" & i - 4) = Split(Range("C" & i), "*")(1)
        Range("H" & i - 4) = Split(Range("C" & i), "*")(2)
    Next i
    Columns(3).ClearContents
    For i = 6 To Range("F" & Rows.Count).End(xlUp).Row
        Cells(i, 9) = Cells(i, 8) * Cells(i, 7)
    Next

End Sub
Sub abc2()
    Dim i As Long, k As Long, T As Long
    Dim InputData(), OutputData()
    Dim Dic As Object
    Set Dic = CreateObject("Scripting.dictionary")
    InputData = Sheet1.Range("F6:I" & Sheet1.[F65000].End(xlUp).Row).Value
    ReDim OutputData(1 To UBound(InputData), 1 To 4)
    For i = 1 To UBound(InputData)
        If Not Dic.exists(InputData(i, 1)) Then
            k = k + 1
            Dic(InputData(i, 1)) = k
            OutputData(k, 1) = InputData(i, 1): OutputData(k, 2) = InputData(i, 2): OutputData(k, 4) = InputData(i, 4)
        Else
            T = Dic.Item(InputData(i, 1))
            OutputData(T, 2) = OutputData(T, 2) + InputData(i, 2)
            OutputData(T, 4) = OutputData(T, 4) + InputData(i, 4)
            OutputData(T, 3) = OutputData(T, 4)
        End If
    Next
    Sheet1.Range("F6:I1000").ClearContents
    Sheet1.Range("F6").Resize(k, 3) = OutputData
    Set Dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Bài này anh đã chia ra làm 2 phần thì Code luôn phần đầu vào mảng đi anh, không cần phải gộp ngay, chia ra để trị cũng được mà.

Bước 1: Tạo Array chứa thông tin sau khi Split dấu ;
Bước 2: Tạo Array chứa thông tin sau khi Split dấu *
Bước 3: Add Dic

Dài dài "tí" (bằng quả mướp :v) nhưng lâu lâu mò lại đọc code dễ hiểu hơn.
 
Upvote 0
HieuCD đã viết:
Mình quên nhân cho sản lượng
Arr(ik, 3) = Arr(ik, 3) + CDbl(S(2))
Chỉnh lại
Arr(ik, 3) = Arr(ik, 3) + CDbl(S(1)) * CDbl(S(2))
Mã: 
Sub GPE()
  Dim Dic As Object, dArr As Variant, Arr As Variant, tmp As Variant, S As Variant
  Dim i As Long, j As Integer, k As Long, ik As Long, key As String
  Set Dic = CreateObject("Scripting.dictionary")
  dArr = Range("B6", Range("B" & Rows.Count).End(xlUp)).Value
  ReDim Arr(1 To UBound(dArr), 1 To 3)
  For i = 1 To UBound(dArr)
      tmp = Split(dArr(i, 1), ";")
      For j = LBound(tmp) To UBound(tmp)
          S = Split(tmp(j), "*")
          If UBound(S) = 2 Then
              key = S(0)
              If Not Dic.exists(key) Then
                  k = k + 1
                  Dic.Add key, k
                  Arr(k, 1) = key
              End If
              ik = Dic.Item(key)
              Arr(ik, 2) = Arr(ik, 2) + CDbl(S(1))
              Arr(ik, 3) = Arr(ik, 3) + CDbl(S(1)) * CDbl(S(2))
          End If
      Next j
  Next i
  i = Range("F" & Rows.Count).End(xlUp).Row
  If i > 5 Then Range("F6:H" & i).ClearContents
  Range("F6:H6").Resize(k) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...

Em ĐÃ test code anh và thấy nó quá tuyệt vời. Nhanh, Gọn, Chính xác. Mà e đã test 1 dòng gồm 50 tên hàng em quất 10.000 dòng mà sao nó không bị lổi vẫn đúng hay thiệt. tại em sợ nó tách ra = 50 *10.000 = 500.000 Mà excel 2003 nó không chứa nổi số dòng. rất cảm ơn anh nhé ! Có dịp sẽ mời 1 bửa nhậu ( Nhà e ở Phú Nhuận )
 
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

HeSanbi
  • Question Question
Sự khác nhau giữa book.Worksheets và book.Sheets trong Application (3 người xem)
Trả lời
1
Đọc
52
VetMini
V
V
  • Question Question
Đếm xếp loại của đơn hàng (1 người xem)
Trả lời
8
Đọc
129
vanlinh_2904
V
N
  • Question Question
Nhờ mọi người góp ý cho file Quản lý bán hàng viết bằng VBA đầu tay của mình (1 người xem)
Trả lời
2
Đọc
25
newbiexo
N
J
Công thức tính lương khi mỗi tháng tăng lương cơ bản (1 người xem)
Trả lời
2
Đọc
52
jangne88
J
H
Xin được trợ giúp lỗi máy không mở được cửa sổ VBE.
Trả lời
0
Đọc
17
HUONGHCKT
H
phatnguyen7301
  • Question Question
Viết code không trùng dữ liệu
Trả lời
3
Đọc
95
VetMini
V
HeSanbi
  • Question Question
GPEStudio - Ứng dụng hỗ trợ tương tác giữa Excel và diễn đàn GPE
    • Thích
Trả lời
0
Đọc
56
HeSanbi
HeSanbi
yeudoi
Cà phê giao lưu cùng thành viên kỳ cựu Cao Mạnh Sơn 19h 23/2/2025
    • Thích
Trả lời
0
Đọc
28
yeudoi
yeudoi
HeSanbi
  • Question Question
FlashSheet v1.1 - Di chuyển qua lại tức thời giữa các trang tính
    • Thích
    • Yêu thích
Trả lời
3
Đọc
574
HeSanbi
HeSanbi
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
15 16 17
Trả lời
325
Đọc
24K
ongke0711
ongke0711
Việt Nguyễn 86
Excel hay bị tắt đột ngột và hiện trang trắng khi làm việc
Trả lời
6
Đọc
219
HeSanbi
HeSanbi
Manhhung90
Thoát chế độ Read only file word. Nhờ mọi người giúp ạ
Trả lời
5
Đọc
88
Manhhung90
Manhhung90
H
chuyển dữ liệu từ 1 dòng thành nhiều dòng theo điều kiện cho trước.
Trả lời
3
Đọc
93
hanhnguyen12022021
H
N
Không chạy được file VBA
Trả lời
2
Đọc
94
hoangtuan.net
hoangtuan.net
H
Quản Lý Công Văn đi Và đến
9 10 11
Trả lời
214
Đọc
159K
ptm0412
ptm0412
T
Em muốn xin chỉ giáo file excel theo dõi thu chi, lãi lỗ của từng xe để báo cáo ạ
Trả lời
3
Đọc
96
VetMini
V
S
RemoveDuplicates Adodb VBA
Trả lời
0
Đọc
74
sykika
S
G
  • Question Question
BẢO MẬT VBAPROJECT
Trả lời
0
Đọc
129
giaoluu1231
G
sangvanng92
  • Question Question
Phân quyền user truy cập
Trả lời
9
Đọc
190
Hoàng Tuấn 868
H
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
7
Đọc
157
DinhManh1307
DinhManh1307
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
TALKSHOW KHÁM PHÁ SỨC MẠNH HÀM FILTER TRONG EXCEL 365
Back
Top Bottom