Các câu hỏi về mảng trong VBA (Array)

[viehoai]

Xin các anh chị giúp đỡ Code Gán các giá trị của một Range là các phần tử của Mãng
Ví dụ: Tôi có các giá trị của Range("A1:A10"). Tôi muốn viết code để gán giá trị của các cells từ A1:A10 là các phần tử của Mãng Arr chẳn hạn.
Xin cảm ơn các anh chị

 

[AutoReply]

Sửa như nào thì em chịu rồi.

Anh đừng khiêm tốn nữa. Em biết anh làm được mà, chịu khó giúp em với.

 

[HieuCD]

Anh chị cho em hỏi thêm về phương thức ReDim Preserve với ạ:
Em có 1 Code để chuyển từ hàng sang cột và dùng ReDim Preserve để tăng kích thước chiều thứ 2 của mảng

Public Sub Chuyendulieu()
    Dim Dic As Object, Tem As String, Tam, Col As Long, R As Long
    Dim sArr(), tArr(), I As Long, K As Long
Set Dic = CreateObject("Scripting.Dictionary")
sArr = Range("A2", Range("B" & Rows.Count).End(3)).Value
Col = 2
ReDim tArr(1 To UBound(sArr), 1 To Col)
ReDim Tam(1 To UBound(sArr), 1 To 1)
For I = 1 To UBound(sArr, 1)
    If sArr(I, 1) <> Empty Then
        Tem = sArr(I, 1)
        If Not Dic.Exists(Tem) Then
            K = K + 1
            Dic.Add Tem, K
            tArr(K, 1) = Tem: tArr(K, 2) = sArr(I, 2): Tam(K, 1) = 2
        Else
            R = Dic.Item(Tem): Tam(R, 1) = Tam(R, 1) + 1
            If Col < Tam(R, 1) Then
                Col = Tam(R, 1)
                If Col > Columns.Count Then Exit Sub
                ReDim Preserve tArr(1 To UBound(sArr), 1 To Col)
            End If
            tArr(R, Tam(R, 1)) = sArr(I, 2)
        End If
    End If
Next I
Range("J2").Resize(K, UBound(tArr, 2)) = tArr
Set Dic = Nothing
End Sub

Nhưng khi Col=404 thì báo lỗi Out of Memory
Vậy Anh (Chị ) cho em hỏi kích thước chiều 2 nhận được tối đa là bao nhiêu không ạ
Em cám ơn Anh (Chị nhiều)

Code viết dài chạy nhanh hơn code ngắn

Public Sub Chuyendulieu()
  Dim Dic As Object, key As String, sArr As Variant, Arr As Variant, tArr As Variant
  Dim i As Long, k As Long, ik As Long, Col As Long, jmax As Long
 
  Set Dic = CreateObject("Scripting.Dictionary")
  sArr = Range("A2", Range("B" & Rows.Count).End(3)).Value
  ReDim tArr(1 To UBound(sArr), 1 To 2)
  For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) <> Empty Then
      key = sArr(i, 1)
      If Not Dic.Exists(key) Then
        k = k + 1
        Dic.Add key, k
        tArr(k, 1) = key: tArr(k, 2) = 2
      Else
        ik = Dic.Item(key)
        Col = tArr(ik, 2) + 1
        tArr(ik, 2) = Col
      End If
      If jmax < Col Then jmax = Col
    End If
  Next i
  ReDim Arr(1 To k, 1 To jmax)
  For i = 1 To k
    Arr(i, 1) = tArr(i, 1)
    tArr(i, 2) = 2
  Next i
  For i = 1 To UBound(sArr, 1)
    key = sArr(i, 1)
    If key <> Empty Then
      ik = Dic.Item(key)
      Col = tArr(ik, 2)
      Arr(ik, Col) = sArr(i, 2)
      tArr(ik, 2) = Col + 1
    End If
  Next i
 
  Range("E2").Resize(k, jmax) = Arr
  Set Dic = Nothing
End Sub

Nếu thích thì bạn viết bẩy lổi số cột nhiều hơn số cột của Sheet

 

[ndu96081631]

Chả hiểu nó là cái giống gì nữa, phải nói yêu cầu người khác mới biết đường mà tìm chứ. Tui chỉ gợi ý cái ReDim Preserve thôi, cái này đại kỵ khi dùng, phải rất thạo mới dúng nhé, mỗi lần redim máy tính nó lại cấp phát bộ nhớ mới, và đống công việc khác sẽ được thực hiện, Preserve thì khỏi phải nói. Nó lại đi copy dữ liệu loạn lện, chốt lại mà nói code chạy chậm ngang rùa bò ( thực tế đã chứng mình cái file này của bạn nó chạy chấm quá trời quá đất)
"Nghẹn ngào tôi nghe như trời đất vỡ
Xót xa phố phường, ôi dâng bao căm hờn "

Thế thì thử thí nghiệm vầy đi
1> Sửa

ReDim tArr(1 To UBound(sArr), 1 To Col)

Thành:

ReDim tArr(1 To 1000, 1 To 30000)

2> Xóa dòng:

ReDim Preserve tArr(1 To UBound(sArr), 1 To Col)

3> Sửa:

Range("J2").Resize(K, UBound(tArr, 2)) = tArr

Thành:

Range("J2").Resize(K, Col) = tArr

Xong chạy lại code xem sao rồi tính tiếp

 

[♫ђöล♥ßล†♥†µ♫]

Thay đổi thuật toán chứ sao? Mà chả hiểu người ta dùng cái exit sub để làm cái gì cơ chứ, thoát sub, mọi thứ như không.

Em đầu tiên em nghĩ là cái đó lớn hơn cột trong bảng tính thì thoát thôi. Chứ đâu nghĩ nó ra sự tình này

 

[truongvu317]

Em đầu tiên em nghĩ là cái đó lớn hơn cột trong bảng tính thì thoát thôi. Chứ đâu nghĩ nó ra sự tình này

Tui thấy bạn viết dữ liệu vào cột J thì phải, vậy phép so sánh số cột trong bảng tính với số cột trong mảng cũng không còn chính xác nưa rùi. Nếu viết dữ liệu vào cột A thì còn tạm chấp nhận được, khi bị số cột lớn quá người ta lập trình báo lỗi như thế nào đó chứ không ai lại âm thầm kết thúc thủ tục này.
Theo đó thì phương án của ndu3721 cũng đi theo gió thôi.

 

[♫ђöล♥ßล†♥†µ♫]

Code viết dài chạy nhanh hơn code ngắn

Public Sub Chuyendulieu()
  Dim Dic As Object, key As String, sArr As Variant, Arr As Variant, tArr As Variant
  Dim i As Long, k As Long, ik As Long, Col As Long, jmax As Long
 
  Set Dic = CreateObject("Scripting.Dictionary")
  sArr = Range("A2", Range("B" & Rows.Count).End(3)).Value
  ReDim tArr(1 To UBound(sArr), 1 To 2)
  For i = 1 To UBound(sArr, 1)
    If sArr(i, 1) <> Empty Then
      key = sArr(i, 1)
      If Not Dic.Exists(key) Then
        k = k + 1
        Dic.Add key, k
        tArr(k, 1) = key: tArr(k, 2) = 2
      Else
        ik = Dic.Item(key)
        Col = tArr(ik, 2) + 1
        tArr(ik, 2) = Col
      End If
      If jmax < Col Then jmax = Col
    End If
  Next i
  ReDim Arr(1 To k, 1 To jmax)
  For i = 1 To k
    Arr(i, 1) = tArr(i, 1)
    tArr(i, 2) = 2
  Next i
  For i = 1 To UBound(sArr, 1)
    key = sArr(i, 1)
    If key <> Empty Then
      ik = Dic.Item(key)
      Col = tArr(ik, 2)
      Arr(ik, Col) = sArr(i, 2)
      tArr(ik, 2) = Col + 1
    End If
  Next i
 
  Range("E2").Resize(k, jmax) = Arr
  Set Dic = Nothing
End Sub

Nếu thích thì bạn viết bẩy lổi số cột nhiều hơn số cột của Sheet

Cám ơn anh @HieuCD rất nhiều và em cám ơn Chị @truongvu317, và Thầy @ndu96081631
Đúng là ReDim Preserve hôm nay em mới tìm tòi và áp dụng ạ

 

[truongvu317]

Chị @truongvu317,

Định trêu tui chắc.

 

[♫ђöล♥ßล†♥†µ♫]

Định trêu tui chắc.

Úi. Trước khi trả lời em có vào xem thông tin cá nhân. Rõ ràng là Chị mà

 

[truongvu317]

Úi. Trước khi trả lời em có vào xem thông tin cá nhân. Rõ ràng là Chị mà

Tui là boy và rất dốt tiếng anh, có khi lúc đăng ký n i ck tui chọn sai giới tính cũng nên.

 

[ndu96081631]

0

Theo đó thì phương án của ndu3721 cũng đi theo gió thôi.

khi có lỗi xuất hiện mà chưa biết lỗi từ đâu, tôi thường thử nghiệm bằng con số cụ thể
Bài ở trên cũng là dạng gợi ý thí nghiệm chứ không phải giải pháp (ai lại ReDim tArr(1 To 1000, 1 To 30000) chứ)
Thí nghiệm... thí nghiệm... và thí nghiệm... để tìm ra chân lý. Cách làm của tôi là vậy (vì xa trường học mà)

 

[truongvu317]

0
khi có lỗi xuất hiện mà chưa biết lỗi từ đâu, tôi thường thử nghiệm bằng con số cụ thể
Bài ở trên cũng là dạng gợi ý thí nghiệm chứ không phải giải pháp (ai lại ReDim tArr(1 To 1000, 1 To 30000) chứ)
Thí nghiệm... thí nghiệm... và thí nghiệm... để tìm ra chân lý. Cách làm của tôi là vậy (vì xa trường học mà)

Ý em nói là thuật toán gốc, hay code của bạn ý ngay từ ban đầu đã có sự vộ lý rồi.

If Col > Columns.Count Then Exit Sub

Code trên muốn kiểm tra xem số cột mà lớn hơn tổng số cột của sheet thì thoát. số cột tối đa là 16384, giả sử col= 16383, code hoạt động bình thường, nhưng đến lúc đẩy dữ liệu xuống sheet sẽ bị lỗi, vì nhớ rằng dữ liệu được viết tại cột J trở đi chứ không phải là cột A. Cái khó là ở chỗ phải xác định được số cột cần thiết, rồi redim một phát là sẽ được. Cho 2 vòng lặp, một vòng dùng để tính col cần thiết, một vòng để copy dữ liệu là xong,

PS: Cha nội này nghịch vừa thôi, kêu redim mảng lớn thế là teo máy của người ta cũng nên.

 

[themorzer]

Tôi sửa hàm của bạn lại 1 chút:

Function listterminal1(ByVal ltArray, ByVal ter)
  'ltArray phải là 1 mảng 2 chiều
  Dim aDes, aTmp
  Dim lR As Long, lC As Long, idx As Long
  Dim lUB1 As Long, lUB2 As Long, lLB1 As Long, lLB2 As Long
  aTmp = ltArray
  lLB1 = LBound(aTmp, 1): lUB1 = UBound(aTmp, 1)
  lLB2 = LBound(aTmp, 2): lUB2 = UBound(aTmp, 2)
  ReDim aDes(lLB1 To lUB1, lLB2 To lUB2)
  For lR = lLB1 To lUB1
    If aTmp(lR, 1) = ter Then
      idx = idx + 1
      For lC = lLB2 To lUB2
        aDes(idx + lLB1 - 1, lC) = aTmp(lR, lC)
      Next
    End If
  Next
  If idx Then listterminal1 = aDes
End Function

Bạn xem file ví dụ mẫu để biết cách áp dụng

chào thầy em áp dụng code của thầy thì phần Listbox của em xuất hiện thêm dòng rỗng


e muốn chỉ xuất hiện dữ liệu khi khác rỗng, còn nếu rỗng báo lỗi
em có sửa lại code

Function listterminal(ByVal sArray, ByVal ter)
  'ltArray phai là 1 mang 2 chieu
  Dim aDes, aTmp
  Dim lR As Long, lC As Long, idx As Long
  Dim lUB1 As Long, lUB2 As Long, lLB1 As Long, lLB2 As Long
  aTmp = sArray
  lLB1 = LBound(aTmp, 1): lUB1 = UBound(aTmp, 1)
  lLB2 = LBound(aTmp, 2): lUB2 = UBound(aTmp, 2)
  ReDim aDes(lLB1 To lUB1, lLB2 To lUB2)
  For lR = lLB1 To lUB1
    If aTmp(lR, 1) = ter Then
      idx = idx + 1
      For lC = lLB2 To lUB2

        If IsEmpty(aTmp(lR, lC)) = False Then

        aDes(idx + lLB1 - 1, lC) = aTmp(lR, lC)
        End If
      Next
    End If
  Next
  If idx Then listterminal = aDes
End Function

để loại bỏ dòng rỗng nhưng vẫn chưa được, mon thầy giúp đỡ

 

[Nam CT]

Chào các anh chị , em có một vấn đề về mảng mong được giúp đỡ:
khi em gán giá trị của một mảng vào một range trong excel, nếu trong trường hợp cột đó đang lọc ( filter) thì sẽ bị lệch dòng. Cho dù đặt tên bảng cũng vậy. Có cách nào để khi đang lọc mà vẫn gán được giá trị của mảng vào bảng không ạ.
Ví dụ như này :
arr = Sheet1.Range("A2:B1000")
Sheet2.Range("bang").Value = arr

 

[tonnydung]

Em đang làm 1 dữ liệu có dùng hàm IF nhưng dữ liệu ít thì không sao giờ dữ liệu nó nhiều lên thì dùng nhiều hàm sẽ rất chậm và có thể Treo nên em hỏi cả nhà em giúp em có cách nào tạo code VBA hàm Array trên Sheet tự động điền thông tin để cho dữ liệu nhẹ đi không ah ?
Em có gửi hình ảnh công thức hàm IF và 1 trong các dữ liệu ở các cột (tât cả các hàng ở cột T,AL,AJ thay đổi thì hàng tương ứng ở cột AN thay đổi theo)

 

[tonnydung]

Em nhờ cả nhà giúp về cái Hà Array tính ngày đến hạn phải thay thế và sửa chữa. Em có gửi File đính kèm.
ở Sheet "KmHangNgay" có thông kê số Km đi hàng ngày của xe. còn ở Sheet KTRA_DENHAN Cột A ghi biển số xe, cột B ghi ngày thay mới đây, cột D là quy định đến bao nhiêu KM sẽ thay, cột E là số Km hiện tại xe đã chạy được bao KM. điều kiện là nếu cột A và B (ở Sheet KTRA_DENHAN) ghi nhận biển số xe mà ngày thay gần nhất là ngày nào thì sẽ Ktra Km tổng từ ngày đó đến nay (VD: ngày 1-5-18 em đã thay dầu thì nó sẽ Ktra tổng Km từ ngày 2-5 ở Sheet KMHangNgay cộng lại nếu đến hoặc vượt quá KM quy định ở cột D là 7000km sẽ thay. Nếu đến nay số Km đã đến 6000km thì cột E hiển thị màu Vàng và hiển thị số tỏng Km từ ngày 2-5 đến nay di duoc bao KM, còn nếu đến 7000km hoặc hơn thì sẽ báo đỏ và cũng hiện thị số Km tổng từ ngày 2-5 đến nay đã đi được) Mục đích em muốn nó tự động báo để mình biết từ ngày thay dầu đến nay thì xe đã đi được bao nhiêu Km và đưa ra quy định bao nhiêu Km sẽ thay nếu đến km thì sẽ báo đỏ để biết. Rất mong được giúp đỡ.

 

[SA_DQ]

Bạn chép macro sự kiện này vô trang 'KemTra_DenHan'

Private Sub Worksheet_Activate()
 Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
 Dim Rws As Long, Ngay As Date, SoKm As Double
 Dim MyAdd As String
 Set Sh = ThisWorkbook.Worksheets("KmHangNgay")
 Rws = Sh.[d1].CurrentRegion.Rows.Count
 Set Rng = Sh.Range("D1").Resize(Rws)
 For Each Cls In Range([A3], [A3].End(xlDown))
    Ngay = Cls.Offset(, 1).Value
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            If sRng.Offset(, -2).Value >= Ngay Then
                SoKm = SoKm + sRng.Offset(, 1).Value
            End If
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        If SoKm > 0 Then
            Cls.Offset(, 4).Value = SoKm:       SoKm = 0
        End If
    Else
        Cls.Interior.ColorIndex = 35
    End If
 Next Cls
End Sub

 

[tonnydung]

Bạn chép macro sự kiện này vô trang 'KemTra_DenHan'

Private Sub Worksheet_Activate()
Dim Sh As Worksheet, Rng As Range, sRng As Range, Cls As Range
Dim Rws As Long, Ngay As Date, SoKm As Double
Dim MyAdd As String
Set Sh = ThisWorkbook.Worksheets("KmHangNgay")
Rws = Sh.[d1].CurrentRegion.Rows.Count
Set Rng = Sh.Range("D1").Resize(Rws)
For Each Cls In Range([A3], [A3].End(xlDown))
    Ngay = Cls.Offset(, 1).Value
    Set sRng = Rng.Find(Cls.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        MyAdd = sRng.Address
        Do
            If sRng.Offset(, -2).Value >= Ngay Then
                SoKm = SoKm + sRng.Offset(, 1).Value
            End If
            Set sRng = Rng.FindNext(sRng)
        Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
        If SoKm > 0 Then
            Cls.Offset(, 4).Value = SoKm:       SoKm = 0
        End If
    Else
        Cls.Interior.ColorIndex = 35
    End If
Next Cls
End Sub

Tks bác nhiều. Nhưng gio em có 3 vấn đề gặp nữa.
1/ Giờ em muốn nếu nhập tiếp ngày thay mới của 1 xe nào đó ở dưới thì nó sẽ chỉ hiển thị Km mới của xe đó ở dưới và ở trên nó sẽ không hiển thị nữa thì có được không ?
2/ EM muốn thêm cả các mục thay Lốp, bảo dưỡng bốn bánh (em có bổ xung thêm vào File mới gửi kèm theo) LƯU Ý ở các mục mới sẽ có 2 điều kiện (1 là Km 2 la ngày đến hạn) nó sẽ báo vào cả 2 cột tương ứng (cột ngày nó sẽ đếm còn bao nhiêu ngày nữa sẽ đến so với ngày hiện tại)
3/ Nếu em muốn thêm vài mục khác nữa cần theo dõi nữa thì em phải thêm vòng lặp ở chỗ nào

 

[SA_DQ]

Nhưng gio em có 3 vấn đề gặp nữa.
1/ Giờ em muốn nếu nhập tiếp ngày thay mới của 1 xe nào đó ở dưới thì nó sẽ chỉ hiển thị Km mới của xe đó ở dưới và ở trên nó sẽ không hiển thị nữa thì có được không ?
2/ EM muốn thêm cả các mục thay Lốp, bảo dưỡng bốn bánh (em có bổ xung thêm vào File mới gửi kèm theo) LƯU Ý ở các mục mới sẽ có 2 điều kiện (1 là Km 2 la ngày đến hạn) nó sẽ báo vào cả 2 cột tương ứng (cột ngày nó sẽ đếm còn bao nhiêu ngày nữa sẽ đến so với ngày hiện tại)
3/ Nếu em muốn thêm vài mục khác nữa cần theo dõi nữa thì em phải thêm vòng lặp ở chỗ nào

(1) Chưa hiểu hết í bạn nên chưa thể làm gì giúp bạn được.

 

[tonnydung]

(1) Chưa hiểu hết í bạn nên chưa thể làm gì giúp bạn được.

Phần 1/ vd: sau het dot 1 báo xong em thay dầu và ghi ngày thay dầu mới của các xe ở dòng tiếp theo (vd: o sheet Denhan. ngay 2/7/18 1 xe đến kỳ và em thay dầu nên em sẽ lại ghi tiếp dữ liệu ở cột A ghi bien so xe cot B ghi ngày thay dầu là 2/7/18 nên em muốn sau khi ghi phía duoi 1 xe nào đó nó sẽ tự xóa số km cảnh báo ở trên và tính tiếp và theo dõi số liệu mới.
2/ ngoai ra em muốn làm thêm các theo dõi khác ở hàng bên cạnh nhu file mới em gui lên thi làm thế nào anh (theo doi moi se tinh ca km va ngày cái nào den truoc thi no tinh

 

[SA_DQ]

(1) Viết thêm cho bạn sẽ được; Nhưng 2 macro sẽ là "sung đột"
Trong khi macro mới sẽ xóa, thì macro trên sẽ điền dữ liệu lại, 1 khi bạn kích hoạt trang tính này (làm hiện hành nó)

Sẽ fải tìm cách khác để 2 chàng này không sẫy ra xung đột mới được.