Lỗi "Out of memory" khi khai báo kích thước mảng

[Thái Phúc]

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

 

[ptm0412]

Dùng 1 vòng lặp con để tìm con số cần khai báo.

    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.

 

[VetMini]

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?

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

 

[huhumalu]

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

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

 

[befaint]

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.

 

[VetMini]

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

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.

 

[ptm0412]

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ạ.

 

[huhumalu]

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.

 

[huuthang_bd]

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.

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ả.

 

[VetMini]

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ạ.

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.

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ả.

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.

 

[huhumalu]

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ả.

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 ..."

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

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

 

[huuthang_bd]

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 ..."

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

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

Thớt đã nói rõ đây chỉ là ví dụ.

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 ạ