nhờ các bạn giúp mình chia các giá trị ra các khoảng bằng nhau (1 người xem)

  • Thread starter Thread starter ntg82vn
  • Ngày gửi Ngày gửi
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)
N

ntg82vn

Thành viên chính thức
Tham gia
1/12/11
Bài viết
53
Được thích
14
Mình có một bài toán này mà đau đầu mấy hôm nay chưa làm được.
Giả sử mình có cột chiều dài, trong cột này có các giá trị (ví dụ 13, 15, 17)
Và mình có cột phân tố (ví dụ giá trị =4).
Bây giờ mình muốn lấy giá trị chia giá trị 13 thành 4,4,4,1. Chia theo các cột.
Sau khi chia hết giá trị 13 rồi tiếp đến giá trị 15 cũng thành 4,4,4,3
Nói chung có bao nhiêu giá trị ở cột thì chia hết thành các phân tố có độ dày bằng nhau và phải lấy số dư của nó.
Mong các bạn sử dụng VBA để giúp mình. (để đơn giản mình chỉ nêu ví dụ trên, còn thực tế dữ liệu rất nhiều nên các bạn sử dụng VBA giúp mình nhe).
Mong sớm hồi âm của các bạn.
Chúc các bạn luôn may mắn và thành đạt
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
Theo file dinh kèm

[ThongBao]Mình có một bài toán này mà đau đầu mấy hôm nay chưa làm được.
Giả sử mình có cột chiều dài, trong cột này có các giá trị (ví dụ 13, 15, 17)
Và mình có cột phân tố (ví dụ giá trị =4).
Bây giờ mình muốn lấy giá trị chia giá trị 13 thành 4,4,4,1. Chia theo các cột.
Sau khi chia hết giá trị 13 rồi tiếp đến giá trị 15 cũng thành 4,4,4,3
Nói chung có bao nhiêu giá trị ở cột thì chia hết thành các phân tố có độ dày bằng nhau và phải lấy số dư của nó.
Mong các bạn sử dụng VBA để giúp mình. (để đơn giản mình chỉ nêu ví dụ trên, còn thực tế dữ liệu rất nhiều nên các bạn sử dụng VBA giúp mình nhe).
Mong sớm hồi âm của các bạn.[/Thongbao]
 

File đính kèm

Upvote 0
Cám ơn bạn đã quan tâm, nhưng vẫn chưa đúng ý của mình bạn ah.
Ví dụ cho trước giá trị chia bằng 4 chẳng hạn thì 13 = 4 + 4 + 4 +1
15 = 4+4+4+3
17=4+4+4+4+1
Bởi vì bạn không thêm dòng
Bạn có thể trả kết quả đúng như mình viết ở dưới không.
Với lại khi mình ấn ALT+F8 thì chương trình không chạy.
Bạn sửa lại giúp mi nhf nhé.
Cám ơn bạn nhiều
 

File đính kèm

Upvote 0
Macro sự kiện mà bạn.

[thongbao]Với lại khi mình ấn ALT+F8 thì chương trình không chạy[/thongbao]
Bạn hãy chọn fân đoạn tại [B2] & kết quả sẽ hiện theo dòng.
 
Upvote 0
vẫn chưa đúng ý của mình bạn ah.
mình có yêu câu như sau:
1. khi mình đánh số thập phân thì báo lỗi (bởi vì chương trình mình cần là đánh số thập phân ở phân tố )
Các bạn xem file mình gửi lên và cố giúp mình nhé.\
Mong sớm hồi âm
 

File đính kèm

Upvote 0
Tại bạn thôi; Trong file ban đầu của bạn có nói đến số thập fân là gì đâu cơ chứ?!
Hay bạn định đánh đố các thành viên khác;

Giờ thì mình hướng đẫn bạn tự sửa đi vậy:

Vô macro, sửa lại khai báo biến CDai có kiểu dữ liệu là 'Double';

Thứ đến, bạn kích hoạt ô [B2] lên & vô menu 'Data' bỏ Validation tại ô đó đi.

Chúc thành công & rút kinh nghiệm lần sau để đỡ tốn thời gian của bạn & của mọi người.
 
Upvote 0
SA_DQ đã viết:
Tại bạn thôi; Trong file ban đầu của bạn có nói đến số thập fân là gì đâu cơ chứ?!
Hay bạn định đánh đố các thành viên khác;

Giờ thì mình hướng đẫn bạn tự sửa đi vậy:

Vô macro, sửa lại khai báo biến CDai có kiểu dữ liệu là 'Double';

Thứ đến, bạn kích hoạt ô [B2] lên & vô menu 'Data' bỏ Validation tại ô đó đi.

Chúc thành công & rút kinh nghiệm lần sau để đỡ tốn thời gian của bạn & của mọi người.
Nhấp chuột vào đây để mở rộng...

Cám ơn bạn rất nhiều, Chúc bạn thành công và luôn gặp nhiều may mắn

bạn ơi mình đã sửa theo lời bạn nói rồi, mình thấy kết quả đúng như mình muốn. Chỉ còn một chút vấn đề nữa thôi. là bây giờ mình muốn kết quả trả theo cột (chứ không phải trả theo hàng) thì mình phải sửa như thế nào. Mong các bạn giúp mình nốt
 
Chỉnh sửa lần cuối bởi điều hành viên:
Upvote 0
Bạn sửa macro sự kiện đó thầnh như vầy:

[thongbao]
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Cls As Range, CDai As Double
 
 If Not Intersect(Target, [B2]) Is Nothing Then
    [A5].CurrentRegion.Offset(, 1).ClearContents    '*'
    [D2:D65500].Clear
    [D1].Value = "GPE.COM"
    For Each Cls In Range([A5], [A5].End(xlDown))
        CDai = Cls.Value
        Do
            If CDai <= Target.Value Then
                With Cells(65500, "D").End(xlUp).Offset(1)
                    .Value = CDai
                    .Interior.ColorIndex = 34 + (Cls.Row Mod 9)
                End With
                Exit Do
            Else
                With Cells(65500, "D").End(xlUp).Offset(1)
                    .Value = Target.Value
                    .Interior.ColorIndex = 34 + (Cls.Row Mod 9)
                End With
                CDai = CDai - Target.Value
            End If
        Loop
    Next Cls
 End If
End Sub
[/thongbao]
 
Upvote 0
ChanhTQ@ đã viết:
[thongbao]
PHP: 
Private Sub Worksheet_Change(ByVal Target As Range)
 Dim Cls As Range, CDai As Double
 
 If Not Intersect(Target, [B2]) Is Nothing Then
    [A5].CurrentRegion.Offset(, 1).ClearContents    '*'
    [D2:D65500].Clear
    [D1].Value = "GPE.COM"
    For Each Cls In Range([A5], [A5].End(xlDown))
        CDai = Cls.Value
        Do
            If CDai <= Target.Value Then
                With Cells(65500, "D").End(xlUp).Offset(1)
                    .Value = CDai
                    .Interior.ColorIndex = 34 + (Cls.Row Mod 9)
                End With
                Exit Do
            Else
                With Cells(65500, "D").End(xlUp).Offset(1)
                    .Value = Target.Value
                    .Interior.ColorIndex = 34 + (Cls.Row Mod 9)
                End With
                CDai = CDai - Target.Value
            End If
        Loop
    Next Cls
 End If
End Sub
[/thongbao]
Nhấp chuột vào đây để mở rộng...

Cám ơn bạn, rất đúng ý của mình, việc còn lại của mình là chỉnh sửa một chút nũa thôi. cám ơn các bạn đã giúp mình trong thời gian vừa qua. Chúc các bạn và gia đình những lời chúc tốt đẹp nhất.
 
Upvote 0
ntg82vn đã viết:
vẫn chưa đúng ý của mình bạn ah.
mình có yêu câu như sau:
1. khi mình đánh số thập phân thì báo lỗi (bởi vì chương trình mình cần là đánh số thập phân ở phân tố )
Các bạn xem file mình gửi lên và cố giúp mình nhé.\
Mong sớm hồi âm
Nhấp chuột vào đây để mở rộng...

Chạy thử code này xem:
Mã: 
Function DivArr(ByVal sArray, ByVal Divisor As Double)
  Dim arr(), aTemp, Item
  Dim n As Long, tmp As Double
  On Error Resume Next
  If Divisor > 0 Then
    aTemp = sArray
    If Not IsArray(aTemp) Then aTemp = Array(aTemp)
    For Each Item In aTemp
      tmp = CDbl(Item)
      If tmp > 0 Then
        n = n + 1
        ReDim Preserve arr(1 To n)
        arr(n) = IIf(tmp <= Divisor, tmp, Divisor)
        Do While tmp > Divisor
          n = n + 1
          ReDim Preserve arr(1 To n)
          tmp = tmp - Divisor
          arr(n) = IIf(tmp <= Divisor, tmp, Divisor)
        Loop
      End If
    Next
    If n Then DivArr = arr
  End If
End Function
Mã: 
Sub Main()
  Dim arr
  Range("D14:D20000").Clear
  arr = DivArr(Range("C4:C20").Value, Range("D2").Value)
  If IsArray(arr) Then
    Range("D14").Resize(UBound(arr)).Value = WorksheetFunction.Transpose(arr)
  End If
End Sub
Cho tất cả code vào 1 Module rồi chạy Sub Main nhé
 
Upvote 0
ndu96081631 đã viết:
Chạy thử code này xem:
Mã: 
Function DivArr(ByVal sArray, ByVal Divisor As Double)
  Dim arr(), aTemp, Item
  Dim n As Long, tmp As Double
  On Error Resume Next
  If Divisor > 0 Then
    aTemp = sArray
    If Not IsArray(aTemp) Then aTemp = Array(aTemp)
    For Each Item In aTemp
      tmp = CDbl(Item)
      If tmp > 0 Then
        n = n + 1
        ReDim Preserve arr(1 To n)
        arr(n) = IIf(tmp <= Divisor, tmp, Divisor)
        Do While tmp > Divisor
          n = n + 1
          ReDim Preserve arr(1 To n)
          tmp = tmp - Divisor
          arr(n) = IIf(tmp <= Divisor, tmp, Divisor)
        Loop
      End If
    Next
    If n Then DivArr = arr
  End If
End Function
Mã: 
Sub Main()
  Dim arr
  Range("D14:D20000").Clear
  arr = DivArr(Range("C4:C20").Value, Range("D2").Value)
  If IsArray(arr) Then
    Range("D14").Resize(UBound(arr)).Value = WorksheetFunction.Transpose(arr)
  End If
End Sub
Cho tất cả code vào 1 Module rồi chạy Sub Main nhé
Nhấp chuột vào đây để mở rộng...

Cám ơn Ndu nhé.
Cám ơn anh em trên diễn đàn rất nhiều.
Chúc các bạn luôn may mắn, hạnh phúc và thành đạt.
 
Upvote 0
ndu96081631 đã viết:
Chạy thử code này xem:
Mã: 
Function DivArr(ByVal sArray, ByVal Divisor As Double)
  Dim arr(), aTemp, Item
  Dim n As Long, tmp As Double
  On Error Resume Next
  If Divisor > 0 Then
    aTemp = sArray
    If Not IsArray(aTemp) Then aTemp = Array(aTemp)
    For Each Item In aTemp
      tmp = CDbl(Item)
      If tmp > 0 Then
        n = n + 1
        ReDim Preserve arr(1 To n)
        arr(n) = IIf(tmp <= Divisor, tmp, Divisor)
        Do While tmp > Divisor
          n = n + 1
          ReDim Preserve arr(1 To n)
          tmp = tmp - Divisor
          arr(n) = IIf(tmp <= Divisor, tmp, Divisor)
        Loop
      End If
    Next
    If n Then DivArr = arr
  End If
End Function
Mã: 
Sub Main()
  Dim arr
  Range("D14:D20000").Clear
  arr = DivArr(Range("C4:C20").Value, Range("D2").Value)
  If IsArray(arr) Then
    Range("D14").Resize(UBound(arr)).Value = WorksheetFunction.Transpose(arr)
  End If
End Sub
Cho tất cả code vào 1 Module rồi chạy Sub Main nhé
Nhấp chuột vào đây để mở rộng...


Mình cám ơn NDU đã giúp mình
Mình thấy rằng khi giá trị ở chiều dài mà chia hết cho giá trị ở phân tố mà lớn hơn 3 thì xuất hiện một giá trị vô cùng bé.(mình đánh dấu ở ô màu vàng)
Khi giá trị ở ô chiều dài mà chia hết cho giá trị ở ô phân tố nhỏ hơn 3 thì mình thấy không xuất hiện giá trị trên.
Bạn có thể giúp mình loại bỏ giá trị vô cùng bé này đi không (tức là khi chạy VBA cho ta kết quả này luôn mà không phải xóa ô này hay không phải xóa dòng có ô này). Bởi vì khi xóa dòng có ô này sẽ ảnh hưởng đến bảng tính của mình, mà để cách ra cũng ảnh hưởng đến bảng tính của mình.
Mình có gửi file lên.
Mong sớm được bạn giúp đỡ.
Thân
 

File đính kèm

Upvote 0
ntg82vn đã viết:
Mình cám ơn NDU đã giúp mình
Mình thấy rằng khi giá trị ở chiều dài mà chia hết cho giá trị ở phân tố mà lớn hơn 3 thì xuất hiện một giá trị vô cùng bé.(mình đánh dấu ở ô màu vàng)
Khi giá trị ở ô chiều dài mà chia hết cho giá trị ở ô phân tố nhỏ hơn 3 thì mình thấy không xuất hiện giá trị trên.
Bạn có thể giúp mình loại bỏ giá trị vô cùng bé này đi không (tức là khi chạy VBA cho ta kết quả này luôn mà không phải xóa ô này hay không phải xóa dòng có ô này). Bởi vì khi xóa dòng có ô này sẽ ảnh hưởng đến bảng tính của mình, mà để cách ra cũng ảnh hưởng đến bảng tính của mình.
Mình có gửi file lên.
Mong sớm được bạn giúp đỡ.
Thân
Nhấp chuột vào đây để mở rộng...

Đó chính là sai sót của bác Bill nói chung trong hầu hết các ứng dụng chứ không riêng gì VBA hay Excel
Bạn có thể làm tròn đến mức nào đó tùy ý
Cụ thể có thể làm tròn như dòng code màu đỏ này:
Mã: 
Function DivArr(ByVal sArray, ByVal Divisor As Double)
  Dim arr(), aTemp, Item
  Dim n As Long, tmp As Double
  On Error Resume Next
  If Divisor > 0 Then
    aTemp = sArray
    If Not IsArray(aTemp) Then aTemp = Array(aTemp)
    For Each Item In aTemp
      tmp = CDbl(Item)
      If tmp > 0 Then
        n = n + 1
        ReDim Preserve arr(1 To n)
        arr(n) = IIf(tmp <= Divisor, tmp, Divisor)
        Do While tmp > Divisor
          n = n + 1
          ReDim Preserve arr(1 To n)
          [COLOR=#ff0000][B]tmp = Round(tmp - Divisor, 2)[/B][/COLOR]
          arr(n) = IIf(tmp <= Divisor, tmp, Divisor)
        Loop
      End If
    Next
    If n Then DivArr = arr
  End If
End Function
 
Upvote 0
Cám ơn Ndu.
Đúng ý của mình rồi.
Một lần nữa, cám ơn bạn rất nhiều.
Bạn có thể giải thich dòng cod sau giúp mình được không

tmp = Round(tmp - Divisor, 2)
 
Lần chỉnh sửa cuối:
Upvote 0
ntg82vn đã viết:
Bạn có thể giải thich dòng cod sau giúp mình được không

tmp = Round(tmp - Divisor, 2)
Nhấp chuột vào đây để mở rộng...

Thì hàm Round dùng để làm tròn thôi mà (như ta thường làm tròn trên bảng tính ấy)
Lý do vì sau 1 số lần dùng phép trừ, Excel sẽ xuất hiện sai số. Khi nào xuất hiện sai số và trường hợp trừ ra sao sẽ xuất hiện sai số thì tôi không biết... Vậy nên cứ làm tròn cho chắc ăn
Ở trên tôi làm tròn 2 số lẻ, bạn có thể chỉnh số 2 thành bao nhiêu tùy ý (tùy theo số liệu trong bảng tính của bạn)
 
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

D
in ra bị thiếu chữ
Trả lời
3
Đọc
31
ptm0412
ptm0412
Momominh
Hỏi công thức tìm tuần thiếu hàng (2 người xem)
Trả lời
1
Đọc
34
hoangtuaotrang_hp_vn
H
2
EM MUỐN TẠO MA TRẬN BIẾN ĐỔI GIÁ TRỊ PHẦN TỬ NGẪU NHIÊN (2 người xem)
Trả lời
2
Đọc
28
ptm0412
ptm0412
V
  • Question Question
Tạo dữ liệu random cho từng sheet dựa theo dữ liệu có sẵn
Trả lời
2
Đọc
69
victoriabmt
V
Emyeuexcel
Cộng 4 tuần theo 1 qui luật qui định
Trả lời
34
Đọc
2K
Emyeuexcel
Emyeuexcel
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba
    • Thích
    • Yêu thích
    • Cảm ơn
2 3 4
Trả lời
394
Đọc
46K
ThanhsonLC
T
hieuxd
  • Question Question
Khi nhập dữ liệu tự động chèn thêm dòng khi số dòng trong bảng mẫu sắp hết
Trả lời
24
Đọc
25K
dungpham01
D
Gà Con yêu VBA
Mở Pass file excel phiên bản .xlsx , xlsm, xlsb
Trả lời
6
Đọc
274
YêuCN
Y
S
Mở 2 cửa sổ riêng biệt
Trả lời
31
Đọc
24K
ThanhNgan240723
T
ongke0711
  • Question Question
Tra cứu thông tin mã số thuế (cập nhật lại code cũ)
    • Thích
    • Cảm ơn
    • Yêu thích
Trả lời
7
Đọc
428
ongke0711
ongke0711
vn81206
TRA CỨU MÃ SỐ THUẾ CÁ NHÂN QUA EXCEL
    • Buồn
Trả lời
57
Đọc
20K
vovietdung261016
V
PhanTuHuong
CHỌN VÀ SỬ DỤNG MÁY LỌC KHÔNG KHÍ (1 người xem)
    • Thích
    • Cảm ơn
Trả lời
7
Đọc
1K
PhanTuHuong
PhanTuHuong
huuthang_bd
Add in SwitchSheet: Quay lại các sheet đã xem trước đó bằng phím tắt
    • Thích
    • Yêu thích
2
Trả lời
146
Đọc
42K
phong_codon
P
N
  • Question Question
Hỗ trợ tiếng việt trong macro
Trả lời
14
Đọc
596
Quang_Hải
Quang_Hải
N
Cài phần mềm đọc số ra chữ
Trả lời
2
Đọc
116
Nguyễn Duy Tuân
Nguyễn Duy Tuân
T
Em cần hỗ trợ tách nhiều file và đặt tên theo quy ước chung từ bảng 01 excel có sẳng
Trả lời
1
Đọc
101
HUONGHCKT
H
N
hàm đếm theo dòng
Trả lời
1
Đọc
87
dungpham01
D
H
LỖI KHOẢNG TRỐNG EXCEL DƯỚI THANH CÔNG CỤ
Trả lời
1
Đọc
60
ptm0412
ptm0412
A
  • Question Question
Share file copy dữ liệu từ tờ khai hải quan.
    • Thích
Trả lời
10
Đọc
987
anhdepjai
A
dungluyen2119
  • Question Question
Code VBA để tính tổng theo chiều ngang mà số cột không cố định
Trả lời
6
Đọc
323
le_vis
L
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