Chọn dãy số sao cho tổng dãy số đó gần bằng nhất với số cho trước. (2 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)
T

thufpts

Thành viên hoạt động
Tham gia
6/8/12
Bài viết
157
Được thích
6
Giới tính
Nam
Nghề nghiệp
Bốc vác
Em chào các bác. em có bài toán này nhưng với khả năng của em không giải quyết được.
Em có một dãy số bất kỳ tại cột G. khi em nhập một giá trị bất kì tại ô màu đỏ ví dụ là 60
thì tại cột H nó sẽ tự động lấy giá trị ở cột G từ trên xuông (bắt buộc) sao cho tổng
ở vùng màu vàng của côt H phải thỏa mãn 1 trong các điều kiện sau
1. bằng ô màu đỏ tại cột H
2. lớn hơn ô màu đỏ tại cột H với giá trị gần nhất ví dụ 61 (tùy vào tổng của vùng màu vàng)
3. nhỏ hơn ô màu đỏ tại cột H với giá trị gần nhất ví dụ 59 (tùy vào tổng của vùng màu vàng).
Mỗi khi giá trị ở cột G thay đổi thì giá trị của vùng màu vàng tại cột H sẽ thay đổi theo.
tương tự khi nhập giá trị bất kì cho các cột I,J,K,L,M
Em rất mong các bác cao thủ giúp em với. em cám ơn các bác nhiều lắm.
 

File đính kèm

Sắp xếp theo thời gian sắp xếp theo bầu chọn
HieuCD đã viết:
vị trí các ô ở các sheet khác có giống với sheet1 không?
Nhấp chuột vào đây để mở rộng...
Có khác bác ạ. đôi khi em sẽ điều chỉnh em nhìn code của bác em có thể điều chỉnh được. nhưng em không biết làm sao để áp dụng cho nhiều sheet
 
Lần chỉnh sửa cuối:
Upvote 0
thufpts đã viết:
Có khác bác ạ. đôi khi em sẽ điều chỉnh em nhìn code của bác em có thể điều chỉnh được. nhưng em không biết làm sao để áp dụng cho nhiều sheet
Nhấp chuột vào đây để mở rộng...
trong mỗi sheet cần chạy code, bạn copy và dán đoạn code sau
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("$H$2:$M$3"), Target) Is Nothing Then
    If Target.Count = 1 Then
        Call GPE
    End If
End If
End Sub
sửa code GPE lại
Mã: 
Sub GPE()
Dim i As Long, j As Integer, t1 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Range("G65000").End(xlUp).Row
Darr = Range("G4:G" & LastR + 1).Value
Sarr = Range("H2:M3").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Upvote 0
HieuCD đã viết:
trong mỗi sheet cần chạy code, bạn copy và dán đoạn code sau
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("$H$2:$M$3"), Target) Is Nothing Then
    If Target.Count = 1 Then
        Call GPE
    End If
End If
End Sub
sửa code GPE lại
Mã: 
Sub GPE()
Dim i As Long, j As Integer, t1 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Range("G65000").End(xlUp).Row
Darr = Range("G4:G" & LastR + 1).Value
Sarr = Range("H2:M3").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Ok rồi bác ạ. chạy ngon quá
 
Upvote 0
HieuCD đã viết:
trong mỗi sheet cần chạy code, bạn copy và dán đoạn code sau
Mã: 
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Range("$H$2:$M$3"), Target) Is Nothing Then
    If Target.Count = 1 Then
        Call GPE
    End If
End If
End Sub
sửa code GPE lại
Mã: 
Sub GPE()
Dim i As Long, j As Integer, t1 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Range("G65000").End(xlUp).Row
Darr = Range("G4:G" & LastR + 1).Value
Sarr = Range("H2:M3").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Bác ơi sau một thời gian chạy em thấy em cần phải di chuyển cột chứa chữ OK thành hàng dọc. ở 1 cột bất kì chẳng hạn cột F.
và mỗi khi nhập ok thì giá trị ở cột G tương ứng mới được tính toán còn không thì bỏ qua. Ví dụ như ảnh bên dưới em đính kèm cả file mong bác giúp em với.

Capture.jpg
 

File đính kèm

Upvote 0
thufpts đã viết:
Bác ơi sau một thời gian chạy em thấy em cần phải di chuyển cột chứa chữ OK thành hàng dọc. ở 1 cột bất kì chẳng hạn cột F.
và mỗi khi nhập ok thì giá trị ở cột G tương ứng mới được tính toán còn không thì bỏ qua. Ví dụ như ảnh bên dưới em đính kèm cả file mong bác giúp em với.
Nhấp chuột vào đây để mở rộng...
bạn nên nhập "ok" ở cột F cho code viết gọn, nếu cột khác F thì báo mình viết lại
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("F4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 And Darr(i, 1) = "ok" Then
                t1 = t1 + Darr(i, 2)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 2)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 2) - t1
                    Darr(i, 2) = Darr(i, 2) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Upvote 0
HieuCD đã viết:
bạn nên nhập "ok" ở cột F cho code viết gọn, nếu cột khác F thì báo mình viết lại
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("F4:G" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 And Darr(i, 1) = "ok" Then
                t1 = t1 + Darr(i, 2)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 2)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 2) - t1
                    Darr(i, 2) = Darr(i, 2) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Bác ơi bác có thể cho code tuy chỉnh được cột bất kỳ được không. vì em em sợ sau này bác không online
mà có vấn đề phát sinh em muốn dịch chuyển cột lại không biết tìm bác ở đâu để hỏi. mong bác giúp đỡ.
 
Upvote 0
thufpts đã viết:
Bác ơi bác có thể cho code tuy chỉnh được cột bất kỳ được không. vì em em sợ sau này bác không online
mà có vấn đề phát sinh em muốn dịch chuyển cột lại không biết tìm bác ở đâu để hỏi. mong bác giúp đỡ.
Nhấp chuột vào đây để mở rộng...
Những yêu cầu dạng này thì nên làm dạng UDF cho dễ dùng.
PHP: 
Function RevTotalTable(RowTotal As Variant, ColTotal As Variant) As Variant
Dim CallerRng As Range, Result() As Variant, i As Long, j As Long, Tmp As Variant, iCol As Long, ArrRow() As Double, ArrCol() As Double, MinVal As Double
On Error Resume Next
Set CallerRng = Application.Caller
If CallerRng Is Nothing Then Exit Function
ReDim ArrRow(1 To CallerRng.Rows.Count)
ReDim ArrCol(1 To CallerRng.Columns.Count)
ReDim Result(1 To CallerRng.Rows.Count, 1 To CallerRng.Columns.Count) As Variant
For Each Tmp In RowTotal
    i = i + 1
    ArrRow(i) = Tmp
Next
i = 0
Tmp = ArrCol
For Each Tmp In ColTotal
    i = i + 1
    ArrCol(i) = Tmp
Next
iCol = 1
For i = 1 To UBound(ArrRow, 1)
    For j = iCol To UBound(ArrCol, 1)
        MinVal = IIf(ArrRow(i) < ArrCol(j), ArrRow(i), ArrCol(j))
        If MinVal > 0 Then
            Result(i, j) = MinVal
            ArrRow(i) = ArrRow(i) - MinVal
            ArrCol(j) = ArrCol(j) - MinVal
        End If
        If ArrRow(i) = 0 Then Exit For
    Next
Next
RevTotalTable = Result
End Function
 

File đính kèm

Upvote 0
thufpts đã viết:
Bác ơi bác có thể cho code tuy chỉnh được cột bất kỳ được không. vì em em sợ sau này bác không online
mà có vấn đề phát sinh em muốn dịch chuyển cột lại không biết tìm bác ở đâu để hỏi. mong bác giúp đỡ.
Nhấp chuột vào đây để mở rộng...
khi cần thay đổi cột thì chỉnh lại cột F trong Oarr= ....
Mã: 
Sub GPE()
Dim i As Long, t1 As Long, t2 As Long, dk As Long
Dim LastR As Long, LastC As Integer, Darr(), Sarr(), Arr(), Oarr()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR + 1).Value
Oarr = Sheet1.Range("F4:F" & LastR + 1).Value
Sarr = Sheet1.Range("H2:M2").Value
LastC = UBound(Sarr, 2)
ReDim Arr(1 To UBound(Darr), 1 To LastC + 1)
Range("H4:M" & LastR).ClearContents
For j = 1 To LastC
    If Sarr(1, j) > 0 Then
        dk = Sarr(1, j)
        t1 = 0
        For i = 1 To UBound(Darr) - 1
            If Arr(i, LastC + 1) <> 123 And Oarr(i, 1) = "ok" Then
                t1 = t1 + Darr(i, 1)
                If t1 <= dk Then
                    Arr(i, j) = Darr(i, 1)
                    Arr(i, LastC + 1) = 123
                    If t1 = dk Then Exit For
                Else
                    Arr(i, j) = Sarr(1, j) + Darr(i, 1) - t1
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    Exit For
                End If
            End If
        Next i
    End If
Next j
Sheet1.Range("H4").Resize(UBound(Arr) - 1, UBound(Arr, 2) - 1) = Arr
End Sub
 
Upvote 0
huuthang_bd đã viết:
Những yêu cầu dạng này thì nên làm dạng UDF cho dễ dùng.
PHP: 
Function RevTotalTable(RowTotal As Variant, ColTotal As Variant) As Variant
Dim CallerRng As Range, Result() As Variant, i As Long, j As Long, Tmp As Variant, iCol As Long, ArrRow() As Double, ArrCol() As Double, MinVal As Double
On Error Resume Next
Set CallerRng = Application.Caller
If CallerRng Is Nothing Then Exit Function
ReDim ArrRow(1 To CallerRng.Rows.Count)
ReDim ArrCol(1 To CallerRng.Columns.Count)
ReDim Result(1 To CallerRng.Rows.Count, 1 To CallerRng.Columns.Count) As Variant
For Each Tmp In RowTotal
    i = i + 1
    ArrRow(i) = Tmp
Next
i = 0
Tmp = ArrCol
For Each Tmp In ColTotal
    i = i + 1
    ArrCol(i) = Tmp
Next
iCol = 1
For i = 1 To UBound(ArrRow, 1)
    For j = iCol To UBound(ArrCol, 1)
        MinVal = IIf(ArrRow(i) < ArrCol(j), ArrRow(i), ArrCol(j))
        If MinVal > 0 Then
            Result(i, j) = MinVal
            ArrRow(i) = ArrRow(i) - MinVal
            ArrCol(j) = ArrCol(j) - MinVal
        End If
        If ArrRow(i) = 0 Then Exit For
    Next
Next
RevTotalTable = Result
End Function
Nhấp chuột vào đây để mở rộng...
Bác ơi với các này em đã cho vào file của em rồi nhưng mà có ít dòng thì không sao file em lên đến 40.000 dòng thì đợi nó tính toán lâu lắm. mất vài phút cho mỗi lần nhập. không còn cách nào khác hả bác.
 
Upvote 0
thufpts đã viết:
Bác ơi với các này em đã cho vào file của em rồi nhưng mà có ít dòng thì không sao file em lên đến 40.000 dòng thì đợi nó tính toán lâu lắm. mất vài phút cho mỗi lần nhập. không còn cách nào khác hả bác.
Nhấp chuột vào đây để mở rộng...
Khi tôi trả lời thì đó là cách tốt nhất mà tôi có thể làm được rồi.
Nếu các cách trước nhanh hơn thì bạn dùng các cách đó đi.
 
Upvote 0
HieuCD đã viết:
code xét "ok" vừa theo dòng và cột, để bạn dể tùy biến
Nhấp chuột vào đây để mở rộng...

cám ơn bác. chạy ổn rồi bác ạ. em không hiểu sao những người lập trình như bác lại nghĩ cách giải quyết nhanh đến vậy.
Những con số những dòng lệnh các bác xử lý nhanh gọn. em chịu không thể hiểu được.
 
Upvote 0
HieuCD đã viết:
code xét "ok" vừa theo dòng và cột, để bạn dể tùy biến
Nhấp chuột vào đây để mở rộng...
Bác ơi. trước khi em nhờ bác giúp em, em xin lỗi bác vì nói thật là em gặp phải tình trạng này
mà thực sự là em không biết trình bày thế nào cả.
Mãi tận hôm nay em nghĩ nát óc mới viết được ra ý tưởng mà đáng lẽ em phải nói từ lúc đầu.
Dữ liệu em dùng rất hay gặp phải tình trạng không phải theo từ trên xuống dưới nữa mà nó rải rác lắm.

Ngoài tùy chọn ok ở cột F em rất muốn có thêm các tùy chọn theo thứ tự ưu tiêu như 1,2,3,4,5,6,7,8
Cùng cột F nếu như tồn tại đồng thời một trong các giá trị ưu tiên như ok,1,2,3,4,5,6,7,8 thì sẽ ưu tiên tính tổng
ok trước sau đó mới đến 1,2,3,4,5,6,7,8 nghĩa là từ trái qua phải và nếu để 0 sẽ không được tính.

Em rất mong bác giúp em vì file của em nó hàng chuc nghìn dòng mà em ngồi làm bằng tay thì em nản và đau đầu lắm.
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
bạn dùng code mới
Mã: 
Sub GPE()
Dim i As Long, n As Long, m As Long, LastR As Long, j As Integer
Dim Darr(), Sarr(), Arr(), Oarr(), Ok123()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR).Value
Sarr = Sheet1.Range("H2:P3").Value
ReDim Arr(1 To UBound(Darr), 1 To UBound(Sarr, 2))
Oarr = Sheet1.Range("F4:F" & LastR).Value
ReDim Ok123(1 To UBound(Oarr), 1 To 1)
n = 1:      Ok123(n, 1) = "ok"
For m = 1 To UBound(Oarr)
    For i = 1 To UBound(Oarr)
        If Oarr(i, 1) = m Then
            n = n + 1: Ok123(n, 1) = m: Exit For
        End If
    Next i
Next m
For m = 1 To n
    For j = 1 To UBound(Sarr, 2)
        If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
            For i = 1 To UBound(Darr)
                If Darr(i, 1) > 0 And Oarr(i, 1) = Ok123(m, 1) Then
                    If Darr(i, 1) <= Sarr(1, j) Then
                        Arr(i, j) = Darr(i, 1)
                    Else
                        Arr(i, j) = Sarr(1, j)
                    End If
                    Sarr(1, j) = Sarr(1, j) - Arr(i, j)
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    If Sarr(1, j) = 0 Then Exit For
                End If
            Next i
        End If
    Next j
Next m
Range("H4:P" & LastR).ClearContents
Sheet1.Range("H4").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub
 
Upvote 0
HieuCD đã viết:
bạn dùng code mới
Mã: 
Sub GPE()
Dim i As Long, n As Long, m As Long, LastR As Long, j As Integer
Dim Darr(), Sarr(), Arr(), Oarr(), Ok123()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR).Value
Sarr = Sheet1.Range("H2:P3").Value
ReDim Arr(1 To UBound(Darr), 1 To UBound(Sarr, 2))
Oarr = Sheet1.Range("F4:F" & LastR).Value
ReDim Ok123(1 To UBound(Oarr), 1 To 1)
n = 1:      Ok123(n, 1) = "ok"
For m = 1 To UBound(Oarr)
    For i = 1 To UBound(Oarr)
        If Oarr(i, 1) = m Then
            n = n + 1: Ok123(n, 1) = m: Exit For
        End If
    Next i
Next m
For m = 1 To n
    For j = 1 To UBound(Sarr, 2)
        If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
            For i = 1 To UBound(Darr)
                If Darr(i, 1) > 0 And Oarr(i, 1) = Ok123(m, 1) Then
                    If Darr(i, 1) <= Sarr(1, j) Then
                        Arr(i, j) = Darr(i, 1)
                    Else
                        Arr(i, j) = Sarr(1, j)
                    End If
                    Sarr(1, j) = Sarr(1, j) - Arr(i, j)
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    If Sarr(1, j) = 0 Then Exit For
                End If
            Next i
        End If
    Next j
Next m
Range("H4:P" & LastR).ClearContents
Sheet1.Range("H4").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
Một phút bác làm bằng 1 năm em cày quốc. thế này đâu phải ma trận nữa. phải gọi là bát quoái trận của gia cát lượng. không hiểu bác làm kiểu gì nữa quá tuyệt vời luôn. cám ơn bác.
 
Upvote 0
HieuCD đã viết:
bạn dùng code mới
Mã: 
Sub GPE()
Dim i As Long, n As Long, m As Long, LastR As Long, j As Integer
Dim Darr(), Sarr(), Arr(), Oarr(), Ok123()
LastR = Sheet1.Range("G65000").End(xlUp).Row
Darr = Sheet1.Range("G4:G" & LastR).Value
Sarr = Sheet1.Range("H2:P3").Value
ReDim Arr(1 To UBound(Darr), 1 To UBound(Sarr, 2))
Oarr = Sheet1.Range("F4:F" & LastR).Value
ReDim Ok123(1 To UBound(Oarr), 1 To 1)
n = 1:      Ok123(n, 1) = "ok"
For m = 1 To UBound(Oarr)
    For i = 1 To UBound(Oarr)
        If Oarr(i, 1) = m Then
            n = n + 1: Ok123(n, 1) = m: Exit For
        End If
    Next i
Next m
For m = 1 To n
    For j = 1 To UBound(Sarr, 2)
        If Sarr(1, j) > 0 And Sarr(2, j) = "ok" Then
            For i = 1 To UBound(Darr)
                If Darr(i, 1) > 0 And Oarr(i, 1) = Ok123(m, 1) Then
                    If Darr(i, 1) <= Sarr(1, j) Then
                        Arr(i, j) = Darr(i, 1)
                    Else
                        Arr(i, j) = Sarr(1, j)
                    End If
                    Sarr(1, j) = Sarr(1, j) - Arr(i, j)
                    Darr(i, 1) = Darr(i, 1) - Arr(i, j)
                    If Sarr(1, j) = 0 Then Exit For
                End If
            Next i
        End If
    Next j
Next m
Range("H4:P" & LastR).ClearContents
Sheet1.Range("H4").Resize(UBound(Arr), UBound(Arr, 2)) = Arr
End Sub
Nhấp chuột vào đây để mở rộng...
có lỗi sảy ra khi nhập từ 1 đến 17 ở cột F
Ok123(n, 1) = m khi đó n = 18 nhưng m = 17. có lẽ phải sửa 1 chút thành

If Oarr(i, 1) = m + 1 Then
n = n + 1: Ok123(n, 1) = m: Exit For
End If
không biết có đúng không
 
Lần chỉnh sửa cuối:
Upvote 0
vnsmac đã viết:
có lỗi sảy ra khi nhập từ 1 đến 17 ở cột F
Ok123(n, 1) = m khi đó n = 18 nhưng m = 17. có lẽ phải sửa 1 chút thành

If Oarr(i, 1) = m + 1 Then
n = n + 1: Ok123(n, 1) = m: Exit For
End If
không biết có đúng không
Nhấp chuột vào đây để mở rộng...
cột F ok là phải có, nên nhập tới số lớn nhất là 17-1=16
còn nếu muốn nhập toàn số thì phải sửa code lại

chỉ cần chỉnh lại khai báo Ok123
Mã: 
ReDim Ok123(1 To UBound(Oarr) [COLOR=#ff0000]+ 1[/COLOR], 1 To 1)
 
Lần chỉnh sửa cuối:
Upvote 0
vnsmac đã viết:
có lỗi sảy ra khi nhập từ 1 đến 17 ở cột F
Ok123(n, 1) = m khi đó n = 18 nhưng m = 17. có lẽ phải sửa 1 chút thành

If Oarr(i, 1) = m + 1 Then
n = n + 1: Ok123(n, 1) = m: Exit For
End If
không biết có đúng không
Nhấp chuột vào đây để mở rộng...
Hiện tại em thấy ổn vì dù sao em vẫn có ok và chưa dùng toàn số.
 
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

SA_DQ
[Xin hỏi] Cách tính số tiền bình quân của tài khoản trong 1 tháng
Trả lời
10
Đọc
165
VetMini
V
A
  • Question Question
Nhờ anh chị em chú bác giúp em viết code vba thay cho công thức dò tìm và tính
Trả lời
2
Đọc
63
A HOANG 620
A
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
12 13 14
Trả lời
262
Đọc
28K
toptikibeauty
T
T
tìm ra số tháng mà lượng hàng nhập ban đầu sử dụng hết
    • Cười
Trả lời
3
Đọc
135
minhminh27
minhminh27
nttrung_proneu
Cách giữ công thức khi lọc và tách file
Trả lời
2
Đọc
60
nttrung_proneu
nttrung_proneu
K
  • Question Question
Code vba đọc QR code file hình ảnh trên CCCD
    • Cười
Trả lời
0
Đọc
64
kingbo.camera
K
Nguyễn Duy Tuân
Phiên bản mới Add-in A-Tools v10 (2024) (2 người xem)
    • Thích
2 3
Trả lời
42
Đọc
3K
Nguyễn Duy Tuân
Nguyễn Duy Tuân
H
  • Question Question
Gửi mail hàng loạt với mỗi mail là 1 file PDF đính kèm khác nhau
Trả lời
1
Đọc
56
minhminh27
minhminh27
B
Làm sao đổi đơn vị B, M này sang hàng đơn vị vậy mọi người?
    • Cười
Trả lời
4
Đọc
67
Bao Nguyen 89
B
C
Tạo hyperlink hàng loạt
Trả lời
9
Đọc
5K
online.tanphat
O
TrungChinhs
  • Question Question
Hỏi cách làm tròn số trong VBA
Trả lời
9
Đọc
7K
SA_DQ
SA_DQ
dongbhhg
Tìm lương cơ sở theo từng tháng
Trả lời
3
Đọc
91
dongbhhg
dongbhhg
V
Làm mẫu giấy đi đường (công lệnh) bằng Excel (1 người xem)
Trả lời
12
Đọc
11K
Gà Công Nghệ
Gà Công Nghệ
N
Thử lập trình XLL add-in bằng C/C++
    • Thích
Trả lời
0
Đọc
91
nguyendang95
N
Tuấn Bụng Bự
tạo QRcode chuyển khoản ngân hàng
Trả lời
5
Đọc
224
Tuấn Bụng Bự
Tuấn Bụng Bự
M
Tự chèn dòng khi cập nhật dữ liệu từ trang tính khác.
Trả lời
1
Đọc
61
BuiQuangThuan
B
Quách Ngọc
Trả về kết quả ngày tháng hay khoảng trống
Trả lời
3
Đọc
70
Quách Ngọc
Quách Ngọc
MaxanB
Cần hỗ trợ công thức Vlookup nhiều sheet theo điều kiên
Trả lời
2
Đọc
93
MaxanB
MaxanB
N
Không chạy được file VBA
Trả lời
3
Đọc
151
nhjngj
N
N
Xin giúp e cách lọc dữ liệu bị trùng
Trả lời
1
Đọc
77
hoangtuaotrang_hp_vn
H
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