Lỗi "Out of memory" khi khai báo kích thước mả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)
Tôi tuân thủ nội quy khi đăng bài
Có
T

Thái Phúc

Thành viên mới
Tham gia
1/12/18
Bài viết
31
Được thích
2
Giới tính
Nam
Xin chào các Anh Chị GPE!
Em có thói quen khi khai báo kích thước mảng động 2 chiều là "ReDim Arr(1 To Rows.Count, 1 To 5)". Lâu nay vẫn chạy bình thường trên máy em, nhưng khi chuyển sang máy khác thì bị lỗi "Out of memory" mặc dù các máy dùng cùng đời office. Vậy em muốn hỏi các Anh Chị lý do xảy ra lỗi và việc em khai báo đã đúng chưa. Các anh chị chia sẻ cách các anh chị khai báo mảng khi chưa biết số dòng (Có thể hàng trăm ngàn dòng) với ạ. Em xin cảm ơn
 
Sắp xếp theo thời gian sắp xếp theo bầu chọn
Thái Phúc đã viết:
"ReDim Arr(1 To Rows.Count, 1 To 5)"
Nhấp chuột vào đây để mở rộng...
Bạn đang hiểu dòng này như nào vậy? Bạn khai báo vậy mình cũng không có dám xài á.
Rows.Count sẽ trả về tổng số dòng khả dĩ trong sheet tính, với excel 2007 trở về trước vào tầm 65 ngàn dòng, còn sau 2007 định dạng ".xlsm" thì 1048576; --> Bạn đang khai báo 1 con số quá khủng khiếp.
Cách làm là tìm ra dòng cuối của khối dữ liệu và sau đó khai báo bằng với kích thước đó thôi;
JavaScript: 
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
ReDim Arr(1 To lastRow, 1 To 5)
 
Upvote 0
Thái Phúc đã viết:
Giả sử lastRow = 10000 nhưng dòng cuối của mảng có thể lớn gấp nhiều lần anh ạ
Nhấp chuột vào đây để mở rộng...
Thì đã cất công đi tìm dòng cuối của khối dữ liệu, còn cái nào cuối hơn của cuối nữa ?
Bạn tìm hiểu dòng
JavaScript: 
lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
hoặc gửi đính kèm file lên trên này, để mọi người xem và góp ý.
1719996140939.jpeg
 
Upvote 0
Thái Phúc đã viết:
Giả sử lastRow = 10000 nhưng dòng cuối của mảng có thể lớn gấp nhiều lần anh ạ
Nhấp chuột vào đây để mở rộng...
Gấp nhiều lần là gấp mấy lần? Tìm cách xác định số lượng hàng nhỏ nhất nhưng đủ để chứa tất cả dữ liệu của mảng trong mọi trường hợp, đó là số lượng hàng tối ưu để khai báo cho mảng.
 
Upvote 0
@Chủ bài đăng: Bạn chịu khó hỏi nó xem dòng cuối nó tìm ra là bao nhiêu cái đã, trước khi khai báo mảng!
 
Upvote 0
SA_DQ đã viết:
@Chủ bài đăng: Bạn chịu khó hỏi nó xem dòng cuối nó tìm ra là bao nhiêu cái đã, trước khi khai báo mảng!
Nhấp chuột vào đây để mở rộng...
Mã: 
Sub TestKhaiBaoKichThuoc()
Dim i As Long, j As Long, K As Long
Dim sArr, dArr, Arr
Dim lastRow As Long
    ReDim dArr(1 To Rows.Count, 1 To 2)
    lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    sArr = Sheets("Sheet1").Range("A2:C" & lastRow).Value
    
    For i = 1 To UBound(sArr)
        If sArr(i, 3) >= sArr(i, 2) Then
            For j = sArr(i, 2) To sArr(i, 3)
                K = K + 1
                dArr(K, 1) = j
                dArr(K, 2) = sArr(i, 1)
            Next j
        
        End If
    Next i
    
    If K Then
        ReDim Arr(1 To K, 1 To 2)
        For i = 1 To K
            Arr(i, 1) = dArr(i, 1)
            Arr(i, 2) = dArr(i, 2)
        Next i
        
        lastRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
        Sheets("Sheet2").Range("A2:B" & lastRow).ClearContents
        Sheets("Sheet2").Range("A2").Resize(K, 2).Value = Arr
    End If
    
End Sub
Đây là cách em làm lâu nay khi viết code kiểu này. Em không biết trước số dòng tối đa của mảng nên cứ khai báo ReDim dArr(1 To Rows.Count, 1 To 2), và trên máy em chạy không việc gì. Hôm nay chuyển file sang máy khác (Cùng đời office) thì bị lỗi. Mong các anh chị giúp đơ ạ!
 

File đính kèm

Upvote 0
một sheet là 1 triệu dòng (gọi vậy cho chẵn)
(1000000, 5) x 16 là 80000000, chả là gì với memory hiện nay.
Có cái gì đó trong "máy khác" của thớt.

Mảng cần một khoảng memory liên tục.
Cái "máy khác" của thớt có thể bị page size thì nhỏ mà "disk fragmentation" nhiều quá.
Đem ra defragment, và chỉnh lại lượng pages thử, may ra còn xài được.
 
Upvote 0
Dung lượng RAM khả dụng trên máy tính đó mà không đủ cho mảng 5 cột thì chỉ có cách tăng dung lượng RAM khả dụng lên thôi.

Bởi số lượng dòng tối ưu cũng sẽ có lúc rơi vào trường hợp dùng tới mức lớn đó.
 
Upvote 0
befaint đã viết:
Dung lượng RAM khả dụng trên máy tính đó mà không đủ cho mảng 5 cột thì chỉ có cách tăng dung lượng RAM khả dụng lên thôi.

Bởi số lượng dòng tối ưu cũng sẽ có lúc rơi vào trường hợp dùng tới mức lớn đó.
Nhấp chuột vào đây để mở rộng...
Vậy có cách gì để "bẫy lỗi" việc này không các Anh Chị. Ví dụ ban đầu vẫn khai báo là "ReDim dArr(1 To Rows.Count, 1 To 2)". Nếu nó xảy ra lỗi thì sẽ khai báo thành " ReDim dArr(1 To 65536, 1 To 2)" chẳng hạn?
 
Upvote 0
Thái Phúc đã viết:
Mã: 
Sub TestKhaiBaoKichThuoc()
Dim i As Long, j As Long, K As Long
Dim sArr, dArr, Arr
Dim lastRow As Long
    ReDim dArr(1 To Rows.Count, 1 To 2)
    lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    sArr = Sheets("Sheet1").Range("A2:C" & lastRow).Value
   
    For i = 1 To UBound(sArr)
        If sArr(i, 3) >= sArr(i, 2) Then
            For j = sArr(i, 2) To sArr(i, 3)
                K = K + 1
                dArr(K, 1) = j
                dArr(K, 2) = sArr(i, 1)
            Next j
       
        End If
    Next i
   
    If K Then
        ReDim Arr(1 To K, 1 To 2)
        For i = 1 To K
            Arr(i, 1) = dArr(i, 1)
            Arr(i, 2) = dArr(i, 2)
        Next i
       
        lastRow = Sheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Row
        Sheets("Sheet2").Range("A2:B" & lastRow).ClearContents
        Sheets("Sheet2").Range("A2").Resize(K, 2).Value = Arr
    End If
   
End Sub
Đây là cách em làm lâu nay khi viết code kiểu này. Em không biết trước số dòng tối đa của mảng nên cứ khai báo ReDim dArr(1 To Rows.Count, 1 To 2), và trên máy em chạy không việc gì. Hôm nay chuyển file sang máy khác (Cùng đời office) thì bị lỗi. Mong các anh chị giúp đơ ạ!
Nhấp chuột vào đây để mở rộng...
Mà đảo mảng qua lại làm gì, lặp một lượt mảng gốc, mỗi dòng lấy ngày cuối trừ ngày đầu, rồi tổng lại thì có bao nhiêu dòng rồi đó
 
Upvote 0
Thái Phúc đã viết:
Đây là cách em làm lâu nay khi viết code kiểu này. Em không biết trước số dòng tối đa của mảng nên cứ khai báo ReDim dArr(1 To Rows.Count, 1 To 2), và trên máy em chạy không việc gì. Hôm nay chuyển file sang máy khác (Cùng đời office) thì bị lỗi. Mong các anh chị giúp đơ ạ!
Nhấp chuột vào đây để mở rộng...
.
Nhập công thức này vào F1 chẳng hạn, rồi lấy giá trị của nó để khai báo mảng, Bỏ vòng lặp thứ hai trong code của bạn:

=SUMPRODUCT(C2:C30-B2:B30+(C2:C30>0))

Như dữ liệu trong file là 27812 dòng
 
Upvote 0
Nhattanktnn đã viết:
Mà đảo mảng qua lại làm gì, lặp một lượt mảng gốc, mỗi dòng lấy ngày cuối trừ ngày đầu, rồi tổng lại thì có bao nhiêu dòng rồi đó
Nhấp chuột vào đây để mở rộng...
Tính vầy là thiếu rồi, số thiếu đúng bằng số dòng của mảng gốc. :D
--
Có thể dùng Evaluate tính trực tiếp trong code như vầy:
Mã: 
sodong = Evaluate(Replace(Replace("sum(sh!c2:c99-sh!b2:b99+1)", "99", lastRow), "sh", "'" & Sheet1.Name & "'"))
 
Upvote 0
huuthang_bd đã viết:
Tính vầy là thiếu rồi, số thiếu đúng bằng số dòng của mảng gốc. :D
--
Có thể dùng Evaluate tính trực tiếp trong code như vầy:
Mã: 
sodong = Evaluate(Replace(Replace("sum(sh!c2:c99-sh!b2:b99+1)", "99", lastRow), "sh", "'" & Sheet1.Name & "'"))
Nhấp chuột vào đây để mở rộng...
Nhờ Anh chỉ giúp bẫy lỗi đối với những dạng bài toán này với ạ! Vì code ở trên là em chỉ ví dụ trường hợp mảng động thôi ạ
 
Upvote 0
huuthang_bd đã viết:
Tính vầy là thiếu rồi, số thiếu đúng bằng số dòng của mảng gốc. :D
--
Có thể dùng Evaluate tính trực tiếp trong code như vầy:
Mã: 
sodong = Evaluate(Replace(Replace("sum(sh!c2:c99-sh!b2:b99+1)", "99", lastRow), "sh", "'" & Sheet1.Name & "'"))
Nhấp chuột vào đây để mở rộng...
Bộp chộp thiếu mất +1 anh ạ!
 
Upvote 0
Nếu là mình thì thay vì
PHP: 
  ReDim dArr(1 To Rows.Count, 1 To 2)
    lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Mình sẽ đi xác định
Mã: 
    lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
sau đó mới xài

ReDim dArr(1 To lastRow, 1 To 2)
 
Upvote 0
Thái Phúc đã viết:
Nhờ Anh chỉ giúp bẫy lỗi đối với những dạng bài toán này với ạ! Vì code ở trên là em chỉ ví dụ trường hợp mảng động thôi ạ
Nhấp chuột vào đây để mở rộng...
Tôi làm cho bạn 2 ví dụ.
Sub Test1 sẽ thử khai báo mảng với 1048576 dòng, nếu lỗi thì khai báo với 65536 dòng, xử lý lỗi ngay trong sub.
Sub Test1 dùng một hàm phụ để khai báo mảng, nếu lỗi sẽ giảm dần chỉ số dòng đến khi có thể khai báo được.
Mã: 
Sub Test1()
    On Error GoTo XyLyLoi
    Dim Arr As Variant
10  ReDim Arr(1 To 1048576, 1 To 500)
    MsgBox "Mang duoc khai bao voi kich thuoc " & UBound(Arr, 1) & "x500"
Exit Sub
XyLyLoi:
    If Erl = 10 Then
        On Error GoTo 0
        ReDim Arr(1 To 65536, 1 To 500)
        Resume Next
    Else
        On Error GoTo 0
        Resume
    End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Test2()
    Dim Arr As Variant
    RedimArray Arr, 10 ^ 6, 500
    MsgBox "Mang duoc khai bao voi kich thuoc " & UBound(Arr, 1) & "x500"
End Sub
Private Sub RedimArray(ByRef Arr As Variant, ByVal UB1 As Long, ByVal UB2 As Long)
    On Error Resume Next
    Do
        Err.Clear
        ReDim Arr(1 To UB1, 1 To UB2)
        UB1 = UB1 - 50000
    Loop Until Err.Number = 0 Or UB1 < 1
End Sub
 
Upvote 0
huuthang_bd đã viết:
Tôi làm cho bạn 2 ví dụ.
Sub Test1 sẽ thử khai báo mảng với 1048576 dòng, nếu lỗi thì khai báo với 65536 dòng, xử lý lỗi ngay trong sub.
Sub Test1 dùng một hàm phụ để khai báo mảng, nếu lỗi sẽ giảm dần chỉ số dòng đến khi có thể khai báo được.
Mã: 
Sub Test1()
    On Error GoTo XyLyLoi
    Dim Arr As Variant
10  ReDim Arr(1 To 1048576, 1 To 500)
    MsgBox "Mang duoc khai bao voi kich thuoc " & UBound(Arr, 1) & "x500"
Exit Sub
XyLyLoi:
    If Erl = 10 Then
        On Error GoTo 0
        ReDim Arr(1 To 65536, 1 To 500)
        Resume Next
    Else
        On Error GoTo 0
        Resume
    End If
End Sub
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Test2()
    Dim Arr As Variant
    RedimArray Arr, 10 ^ 6, 500
    MsgBox "Mang duoc khai bao voi kich thuoc " & UBound(Arr, 1) & "x500"
End Sub
Private Sub RedimArray(ByRef Arr As Variant, ByVal UB1 As Long, ByVal UB2 As Long)
    On Error Resume Next
    Do
        Err.Clear
        ReDim Arr(1 To UB1, 1 To UB2)
        UB1 = UB1 - 50000
    Loop Until Err.Number = 0 Or UB1 < 1
End Sub
Nhấp chuột vào đây để mở rộng...
Cảm ơn Anh nhiều ạ! Em đang có hướng xử lý thế này có được không ạ:

Mã: 
Function DongCuoiMang(col As Long) As Long
Dim dArr, sArr(), s
On Error Resume Next
sArr = Array(Rows.Count, 500000, 200000, 100000, 65536)
    For Each s In sArr
        Err.Clear
        ReDim dArr(1 To s, 1 To col)
        If Err.Number = 0 Then
            DongCuoiMang = s
            Exit For
        End If
    Next s
End Function
 
Upvote 0
Thái Phúc đã viết:
Cảm ơn Anh nhiều ạ! Em đang có hướng xử lý thế này có được không ạ:

Mã: 
Function DongCuoiMang(col As Long) As Long
Dim dArr, sArr(), s
On Error Resume Next
sArr = Array(Rows.Count, 500000, 200000, 100000, 65536)
    For Each s In sArr
        Err.Clear
        ReDim dArr(1 To s, 1 To col)
        If Err.Number = 0 Then
            DongCuoiMang = s
            Exit For
        End If
    Next s
End Function
Nhấp chuột vào đây để mở rộng...
Đã khai báo được rồi thì dùng mang đó luôn (như tôi làm ở sub Test2) chứ lấy chỉ số dòng làm gì, rồi lại Redim thêm một lần nữa à?
Ngoài ra cũng nói thêm do bạn hỏi cách bẫy lỗi nên tôi ví dụ như vậy nhưng theo tôi không nên làm như vậy. Tốt nhất là chỉ khai báo số dòng vừa đủ dùng, kể cả trong trường hợp phải thêm một vòng lặp để xác định kích thước mảng nếu việc xác định kích thước mảng không phức tạp.
 
Upvote 0
Dùng 1 vòng lặp con để tìm con số cần khai báo.
JavaScript: 
    lastRow = Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
    sArr = Sheets("Sheet1").Range("A2:C" & lastRow).Value
    
For i = 1 To UBound(sArr, 1)
    d = sArr(i, 3) - sArr(i, 2) + 1
    n = n + d
Next
ReDim dArr(1 To n, 1 To 2)
Đó là áp dụng cho file cụ thể này. Những trường hợp dữ liệu khác sẽ có cách tính khác, có thể tương đối chứ không chính xác.
 
Upvote 0
Thái Phúc đã viết:
Vậy có cách gì để "bẫy lỗi" việc này không các Anh Chị. Ví dụ ban đầu vẫn khai báo là "ReDim dArr(1 To Rows.Count, 1 To 2)". Nếu nó xảy ra lỗi thì sẽ khai báo thành " ReDim dArr(1 To 65536, 1 To 2)" chẳng hạn?
Nhấp chuột vào đây để mở rộng...
Bàu #19 bạn làm gần đúng như tôi toan chỉ ra.

1. Muốn bẫy lỗi thì gọi một Sub/Func khác để khỏi làm rối loạn tình trang bẫy lỗi trong Sub gọi.

2. Cứ mở đầu bằng 1 triệu, giảm mỗi lượt là phân nửa.

Function ToiDaMang(ByVal tryMe As Long) As Long
On Error Goto NhoHon
Redim DongTD(1 To tryMe, 1 To 5)
ToiDaMang = tryMe
Exit Function
NhoHon:
On Error Goto -1
ToiDaMang = ToiDaMang(tryMe \ 2)
End Function
 
Lần chỉnh sửa cuối:
Upvote 0
VetMini đã viết:
Bàu #19 bạn làm gần đúng như tôi toan chỉ ra.

1. Muốn bẫy lỗi thì gọi một Sub/Func khác để khỏi làm rối loạn tình trang bẫy lỗi trong Sub gọi.

2. Cứ mở đầu bằng 1 triệu, giảm mỗi lượt là phân nửa.

Function ToiDaMang(ByVal tryMe As Long) As Long
On Error Goto NhoHon
Redim DongTD(1 To tryMe, 1 To 5)
ToiDaMang = tryMe
Exit Function
NhoHon:
On Error Goto -1
ToiDaMang = ToiDaMang(tryMe \ 2)
End Function
Nhấp chuột vào đây để mở rộng...
Bẫy này nó vào lưng lửng thì sao anh nhỉ ?
Nó không Ao ọp nhưng nó lại thiếu dòng :D
 
Upvote 0
Không đối chiếu với dung lượng RAM khả dụng thì đều không đạt.

Tính được chính xác kích thước mảng nhưng RAM có đủ đâu mà chạy.
 
Upvote 0
huhumalu đã viết:
Bẫy này nó vào lưng lửng thì sao anh nhỉ ?
Nó không Ao ọp nhưng nó lại thiếu dòng :D
Nhấp chuột vào đây để mở rộng...
Thì có nghĩa là ứng dụng này không xài được cho máy ấy.
Nếu cố ép thì nó cứ ba bữa chạy, ba bữa ngáp ngáp. Chả nhẽ dán vào nó tờ giấy "Cẩn thận: Macro nảy có lúc không chạy nổi trên máy tính yếu"

Thớt chỉ có ba con đường chọn:
- Phân đoạn/partition: một lần chỉ mở 100000 dòng. Đầy rồi thì ghi vào, clear rồi mở lại 100000 dòng khác. Cái này rất rắc rối, không xứng đáng làm.
- Nâng cấp hay mua máy mới.
- Không chạy trên mãy cũ. Dùng máy mới chạy rồi chuyển qua. Macro sẽ có phần nhận ra máy (hoặc trap lỗi 1000000 dòng) và lên thông báo "Máy bạn không đủ sức chạy Macro này. Xin dùng máy cấu hình cao hơn", và thoát.
 
Upvote 0
Theo bài 1 thì máy tác giả chạy được, máy người khác mới không chạy. Cho nên chẳng cớ gì phải nâng cấp cho máy thiên hạ.
 
Upvote 0
Hoặc theo em khỏi nạp mảng chi sất, cứ lấy sheet táng vào sheet, chậm chút hao tốn tài nhưng dòng theo dòng.
 
Upvote 0
huhumalu đã viết:
Hoặc theo em khỏi nạp mảng chi sất, cứ lấy sheet táng vào sheet, chậm chút hao tốn tài nhưng dòng theo dòng.
Nhấp chuột vào đây để mở rộng...
Theo bạn thì "táng" như thế nào? Nếu gán từng ô thì rất chậm chứ không phải chậm chút. Chưa kể các trường hợp duyệt mảng xử lý năm ba lượt mới ra được kết quả.
 
Upvote 0
ptm0412 đã viết:
Theo bài 1 thì máy tác giả chạy được, máy người khác mới không chạy. Cho nên chẳng cớ gì phải nâng cấp cho máy thiên hạ.
Nhấp chuột vào đây để mở rộng...
Khổ cái nếu bên kia khong chyaj được thì học đổ lỗi cho mình. Lỡ cỡi lưng cọp rồi.

huuthang_bd đã viết:
Theo bạn thì "táng" như thế nào? Nếu gán từng ô thì rất chậm chứ không phải chậm chút. Chưa kể các trường hợp duyệt mảng xử lý năm ba lượt mới ra được kết quả.
Nhấp chuột vào đây để mở rộng...
Bảo người ta ráng chịu. Chứ đồ dỏm đòi chạy file Excel "xịn" (đối với họ là xịn, dới với tôi là dỏm) làm sao được.
 
Upvote 0
huuthang_bd đã viết:
Theo bạn thì "táng" như thế nào? Nếu gán từng ô thì rất chậm chứ không phải chậm chút. Chưa kể các trường hợp duyệt mảng xử lý năm ba lượt mới ra được kết quả.
Nhấp chuột vào đây để mở rộng...
Em biết là chậm hơn nhiều, chiếm tài nguyên như nào em cũng không có đong đếm được.
Chỉ là đang phỏng đoán duyệt từng dòng thì không có nạp tài nguyên tạm thì không có "Out of ..."
JavaScript: 
Sub NoArray()
    Dim i As Long, j As Long, K As Long
    Dim lastRow As Long, maxRows As Long
    Dim ws1 As Worksheet, ws2 As Worksheet

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = "Running..."

    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
 
    lastRws1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lastRws2 = ws2.Range("A" & Rows.Count).End(xlUp).Row 
   
    ws2.Range("A2:B" & lastRws2).ClearContents
   
    k = 1
    For i = 2 To lastRws1
        If ws1.Range("C" & i).Value >= ws1.Range("B" & i).Value Then
            For j = ws1.Range("B" & i).Value To ws1.Range("C" & i).Value
                ws2.Range("A" & k + 1).Value = j
                ws2.Range("B" & k + 1).Value = ws1.Range("A" & i).Value
                k = k + 1
            Next j
        End If
    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
 
End Sub

Phương án dùng cái cắt khúc :D

JavaScript: 
Sub CatKhuc()
    Dim i As Long, j As Long, k As Long
    Dim lastRws1 As Long, lastRws2 As Long, templast As Long, maxRows As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim dataArr() As Variant
  
    maxRows = 1000
    k = 0
    ReDim dataArr(1 To maxRows, 1 To 2)

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = "Running..."

    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
  
    lastRws1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lastRws2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
  
    ws2.Range("A2:B" & lastRws2).ClearContents

    For i = 2 To lastRws1
        If ws1.Range("C" & i).Value >= ws1.Range("B" & i).Value Then
            For j = ws1.Range("B" & i).Value To ws1.Range("C" & i).Value
                k = k + 1
                dataArr(k, 1) = j
                dataArr(k, 2) = ws1.Range("A" & i).Value
               
                If k = maxRows Then
                    templast = ws2.Range("A" & Rows.Count).End(xlUp).Row
                    ws2.Range("A" & templast + 1).Resize(maxRows, 2).Value = dataArr
                    k = 0
                    ReDim dataArr(1 To maxRows, 1 To 2)
                End If
            Next j
        End If
    Next i

    If k > 0 Then
        templast = ws2.Range("A" & Rows.Count).End(xlUp).Row
        ws2.Range("A" & templast + 1).Resize(k, 2).Value = dataArr
    End If
  
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
huhumalu đã viết:
Em biết là chậm hơn nhiều, chiếm tài nguyên như nào em cũng không có đong đếm được.
Chỉ là đang phỏng đoán duyệt từng dòng thì không có nạp tài nguyên tạm thì không có "Out of ..."
JavaScript: 
Sub NoArray()
    Dim i As Long, j As Long, K As Long
    Dim lastRow As Long, maxRows As Long
    Dim ws1 As Worksheet, ws2 As Worksheet

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = "Running..."

    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet2")
 
    lastRws1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lastRws2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
  
    ws2.Range("A2:B" & lastRws2).ClearContents
  
    k = 1
    For i = 2 To lastRws1
        If ws1.Range("C" & i).Value >= ws1.Range("B" & i).Value Then
            For j = ws1.Range("B" & i).Value To ws1.Range("C" & i).Value
                ws2.Range("A" & k + 1).Value = j
                ws2.Range("B" & k + 1).Value = ws1.Range("A" & i).Value
                k = k + 1
            Next j
        End If
    Next i

    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
 
End Sub

Phương án dùng cái cắt khúc :D

JavaScript: 
Sub CatKhuc()
    Dim i As Long, j As Long, k As Long
    Dim lastRws1 As Long, lastRws2 As Long, templast As Long, maxRows As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim dataArr() As Variant
 
    maxRows = 1000
    k = 0
    ReDim dataArr(1 To maxRows, 1 To 2)

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.StatusBar = "Running..."

    Set ws1 = Sheets("Sheet1")
    Set ws2 = Sheets("Sheet3")
 
    lastRws1 = ws1.Range("A" & Rows.Count).End(xlUp).Row
    lastRws2 = ws2.Range("A" & Rows.Count).End(xlUp).Row
 
    ws2.Range("A2:B" & lastRws2).ClearContents

    For i = 2 To lastRws1
        If ws1.Range("C" & i).Value >= ws1.Range("B" & i).Value Then
            For j = ws1.Range("B" & i).Value To ws1.Range("C" & i).Value
                k = k + 1
                dataArr(k, 1) = j
                dataArr(k, 2) = ws1.Range("A" & i).Value
              
                If k = maxRows Then
                    templast = ws2.Range("A" & Rows.Count).End(xlUp).Row
                    ws2.Range("A" & templast + 1).Resize(maxRows, 2).Value = dataArr
                    k = 0
                    ReDim dataArr(1 To maxRows, 1 To 2)
                End If
            Next j
        End If
    Next i

    If k > 0 Then
        templast = ws2.Range("A" & Rows.Count).End(xlUp).Row
        ws2.Range("A" & templast + 1).Resize(k, 2).Value = dataArr
    End If
 
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.StatusBar = False
End Sub
Nhấp chuột vào đây để mở rộng...
Thớt đã nói rõ đây chỉ là ví dụ.
Thái Phúc đã viết:
Nhờ Anh chỉ giúp bẫy lỗi đối với những dạng bài toán này với ạ! Vì code ở trên là em chỉ ví dụ trường hợp mảng động thôi ạ
Nhấp chuột vào đây để mở rộng...
 
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

H
Đánh số thự theo lượt
Trả lời
5
Đọc
74
hongminh_0306
H
V
Quản lý xuất nhập vật tư trong kho
Trả lời
15
Đọc
581
Vũ Hải Sơn
V
D
XIN PHẦN MỀM XẾP TKB TIỂU HỌC BẰNG EXCEL
Trả lời
2
Đọc
131
danhpheo
D
phuongnam366377
Học C++ từ số 0 – Bài học đầu tiên (1 người xem)
    • Cảm ơn
Trả lời
2
Đọc
127
phuongnam366377
phuongnam366377
A
  • Question Question
Copy 2 form sang file khác, có 1 form Show, 1 form không Show
Trả lời
2
Đọc
97
AnhThu-1976
A
R
Các bác có kinh nghiệm excel cho em xin công thức đánh số thứ tự theo ngày tháng này vợi ạ.
Trả lời
5
Đọc
159
truc.duong87
T
H
Tự động cập nhật dữ liệu từ 2 file word
Trả lời
1
Đọc
106
LOGANWover
L
N
Nhờ giúp Drop down list theo tỉnh xã mới.
Trả lời
7
Đọc
295
ongke0711
ongke0711
E
VBA copy ô trong excel khi đang lọc filter (1 người xem)
Trả lời
8
Đọc
152
eagle12
E
ongke0711
  • Question Question
Tải hóa đơn điện tử (https://hoadondientu.gdt.gov.vn/) Excel Vba (8 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
3 4 5
Trả lời
436
Đọc
57K
hangiang
H
N
Không sử dụng được phím tắt Ctrl + Shift + mũi tên xuống (1 người xem)
Trả lời
1
Đọc
3K
aFdangthacmac
A
L
  • Question Question
Gõ và chọn tên trong ComboBox hiển thị giá trị trong textbox
    • Cười
Trả lời
8
Đọc
397
ongke0711
ongke0711
befaint
[ Python và ứng dụng ] Công cụ trích xuất hàng loạt hóa đơn điện tử XML vào bảng Excel (1 người xem)
    • Thích
    • Yêu thích
    • Cảm ơn
Trả lời
56
Đọc
9K
Hoale85
H
Nam168
Không mở được file excel (2 người xem)
Trả lời
2
Đọc
94
Nam168
Nam168
phuongnam366377
Sử dụng COM DLL **không cần đăng ký** với Delphi 12 / C++ Builder (1 người xem)
    • Thích
Trả lời
0
Đọc
117
phuongnam366377
phuongnam366377
N
Định mức nguyên vật liệu
Trả lời
49
Đọc
5K
ntan50
N
H
  • Question Question
Dò tìm giá trị từ bảng khác theo cột
Trả lời
6
Đọc
319
Chả_biết_gì
C
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 (1 người xem)
    • Thích
Trả lời
26
Đọc
1K
haitien123
H
ongke0711
Truy cập trang GPE chậm
    • Thích
Trả lời
3
Đọc
227
Hai Lúa Miền Tây
Hai Lúa Miền Tây
V
Gộp File Từng File Excel vào 1 File
Trả lời
16
Đọc
540
ptm0412
ptm0412
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