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

viehoai · 24/3/11

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ị

ndu96081631 · 14/2/12

trungvdb đã viết:
Rất ổn rồi thày ah, nếu không nhờ thày và anh minhthien giúp chắc bản thân tôi không tìm ra được (chưa phân biệt được mảng 2 chiều và 1 chiều, cứ nghĩ mảng 1 dọc là mảng 2 chiều đặc biệt chiều kia bằng số phần tử, chiều còn lại là 1 chứ... hichic)

Suy nghĩ xem có thể làm được bài này chỉ với 1 vòng lập không?
Ẹc... Ẹc...

Hoàng Trọng Nghĩa · 14/2/12

ndu96081631 đã viết:
Suy nghĩ xem có thể làm được bài này chỉ với 1 vòng lập không?
Ẹc... Ẹc...

Làm thử cho vui, không biết đúng ý Thầy không:

PHP:

Sub Loc2()
    Dim Arr(), DL(), KQ(), Dongcuoi As Long, i As Long, m As Long
    Dongcuoi = Sheet1.[A65000].End(xlUp).Row
    DL = Sheet1.Range("A1:B" & Dongcuoi).Value
    ReDim KQ(1 To UBound(DL, 1), 1 To UBound(DL, 2))
    Arr = Array(1, 2, 3, 4, 5, 6, 7, 8)
    With CreateObject("Scripting.Dictionary")
        For i = 1 To UBound(DL, 1)
            If i < 9 Then
                Tmp = Arr(i - 1)
                If Not .Exists(Tmp) Then .Add Tmp, ""
            End If
            If .Exists(DL(i, 1)) Then
                m = m + 1
                KQ(m, 1) = DL(i, 1): KQ(m, 2) = DL(i, 2)
            End If
        Next
    End With
    With Sheets("sheet2")
        .Range("A:B").ClearContents
        .[A2].Resize(m, 2).Value = KQ
    End With
End Sub

Nhưng cũng e là dữ liệu nhỏ hơn 8 hàng thì sao ta? Ẹc ... Ẹc ...

trungvdb · 14/2/12

Bác Nghĩa đúng là số đỏ quá gặp ngay dữ liệu bài này cho luôn các phần tử Arr nhỏ hơn 9. Thế nhưng trường hợp tổng quát các phần tử củ Arr không tuân theo quy luật nào mà nó là các số ngẫu nhiêu cho vào thì sao ? Hihi

Chắc ý của thày là giải quyết cho dữ liệu tổng quát bác ah

ndu96081631 · 14/2/12

trungvdb đã viết:
Lời giải của bác Nghĩa gặp may trong dữ liệu cụ thể của bài này (chỉ đúng trong TH các phần tử Arr nhỏ hơn 9 thôi), thế trường hợp tổng quát các phần tử củ Arr không tuân theo quy luật nào mà nó là các số ngẫu nhiêu cho vào thì sao ?

Chắc ý của thày là giải quyết cho dữ liệu tổng quát bác ah

Hoặc giả Arr chứa các phần tử là Text chẳng hạn
Ẹc... Ẹc...

nmhung49 · 15/2/12

ndu96081631 đã viết:
2 Dic cũng chưa chắc chậm hơn, ăn tiền ở chổ người ta dùng có 1 vòng lập
Ẹc... Ẹc...
Nếu tôi làm thì cũng thế thôi, tuy nhiên xin góp ý chổ này
- ReDim KQ(1 To UBound(VDL, 1), 1 To 7) ---> Sao bạn biết chắc là 7 cột?
Còn ThuNghi thì viết vầy:
- ReDim ArrKQ(1 To UBound(Arr), 1 To UBound(Arr)) ---> Sẽ lỗi nghiêm trọng nếu dữ liệu lớn
Vì vậy để chắc ăn nên dùng ReDim Preserve cho chiều thứ 2
Tôi giả lập 65536 dòng dữ liệu rồi, mọi người cứ lấy mà thí nghiệm

Nếu ta không biết trước phần tử thì nên dùng Preserve đúng như lời anh Ndu nói và gợi ý vậy mình sửa lại ví dụ bài #251 với dữ liệu 65000 dòng thì tốc độ tăng lên đáng kể

PHP:

Sub Tonghop()
    Dim VDL As Variant, KQ() As Variant, I As Long, N As Long, J As Long
    Dim Dic As Object, T As Double, P1 As Long, P2 As Long
    T = Timer
    Set Dic = CreateObject("Scripting.Dictionary")
    VDL = Range("a2:b65536").Value
    ReDim KQ(1 To UBound(VDL, 1), 1 To 1)
    N = 1: J = 1
    With CreateObject("Scripting.Dictionary")
        For I = 1 To UBound(VDL, 1)
            If Not .Exists(VDL(I, 2)) Then
                N = N + 1
                KQ(N, 1) = VDL(I, 2)
                .Item(VDL(I, 2)) = N
            End If
            If Not Dic.Exists(VDL(I, 1)) Then
                J = J + 1
                Dic(VDL(I, 1)) = J
                If J > UBound(KQ, 2) Then
                    ReDim Preserve KQ(1 To UBound(KQ, 1), 1 To J)
                End If
                KQ(1, J) = VDL(I, 1)
            End If
            P1 = .Item(VDL(I, 2)): P2 = Dic(VDL(I, 1))
            KQ(P1, P2) = KQ(P1, P2) + 1
        
        Next
    End With
   
    With Range("R1")
        .CurrentRegion.ClearContents
        .Resize(N, J).Value = KQ
    End With
    Set Dic = Nothing
    Range("C3").Value = Timer - T
End Sub

nmhung49 · 15/2/12

Hoàng Trọng Nghĩa đã viết:
Nhưng cũng e là dữ liệu nhỏ hơn 8 hàng thì sao ta? Ẹc ... Ẹc ...

Dùng thêm hàm Match của Excel vô chứ sao ta he...he...

ThuNghi · 15/2/12

nmhung49 đã viết:
Dùng thêm hàm Match của Excel vô chứ sao ta he...he...

Nếu kg dùng match hay Instr thì tạm thời chưa biết cách làm 1 for.
NDU làm thử, cám ơn!

ndu96081631 · 15/2/12

nmhung49 đã viết:
Dùng thêm hàm Match của Excel vô chứ sao ta he...he...

Nếu cóc cho dùng bất kỳ thứ gì liên quan đên WorksheetFunction thì sao đây?
Ẹc... Ẹc...

nmhung49 · 16/2/12

ndu96081631 đã viết:
Nếu cóc cho dùng bất kỳ thứ gì liên quan đên WorksheetFunction thì sao đây?
Ẹc... Ẹc...

Thì dùng hàm InStr của VBA nhưng anh ThuNghi nói, không biết anh Ndu có cao kiến gì không cho anh em học hỏi đi

ndu96081631 · 16/2/12

nmhung49 đã viết:
Thì dùng hàm InStr của VBA nhưng anh ThuNghi nói, không biết anh Ndu có cao kiến gì không cho anh em học hỏi đi

Dùng toán tự Like là được rồi...
Thuật toán:

PHP:

sArray = Sheet1.Range("A2:B100").Value
ReDim Arr(1 To UBound(sArray, 1), 1 To 2)
tmpArr = Array(1, 2, 3, 4, 5, 6, 7, 8)
Crit = Chr(0) & Join(tmpArr, Chr(0)) & Chr(0)
For i = 1 To UBound(sArray, 1)
  tmp = "*" & Chr(0) & sArray(i, 1) & Chr(0) & "*"
  If Crit Like tmp Then
    m = m + 1
    Arr(m, 1) = sArray(i, 1)
    Arr(m, 2) = sArray(i, 2)
  End If
Next

ThuNghi · 16/2/12

ndu96081631 đã viết:

Dùng toán tự Like là được rồi...
Thuật toán:

PHP:

sArray = Sheet1.Range("A2:B100").Value
ReDim Arr(1 To UBound(sArray, 1), 1 To 2)
tmpArr = Array(1, 2, 3, 4, 5, 6, 7, 8)
Crit = Chr(0) & Join(tmpArr, Chr(0)) & Chr(0)
For i = 1 To UBound(sArray, 1)
  tmp = "*" & Chr(0) & sArray(i, 1) & Chr(0) & "*"
  If Crit Like tmp Then
    m = m + 1
    Arr(m, 1) = sArray(i, 1)
    Arr(m, 2) = sArray(i, 2)
  End If
Next

Quá hay nhưng vẫn chậm hơn Instr
Với tmpArr = Array(1, 2, 3, 4, 5, 6, 7, 8) thì dùng like hay instr sẽ nhanh hơn Dic với dữ liệu 60.000 rows.
Nhưng thay những số 1,2 ... kia thành text thì Dic nhanh hơn.
Cám ơn NDU.
Dùng Instr

PHP:

sArray = Sheet1.Range("A2:B60000").Value
ReDim Arr(1 To UBound(sArray, 1), 1 To 2)
tmpArr = Array(1, 2, 3, 4, 5, 6, 7, 8)
Crit = Join(tmpArr, vbBack)
For i = 1 To UBound(sArray, 1)
  Tmp = sArray(i, 1) & vbBack
  If InStr(Crit, Tmp) Then
    m = m + 1
    Arr(m, 1) = sArray(i, 1)
    Arr(m, 2) = sArray(i, 2)
  End If
Next

ndu96081631 · 16/2/12

ThuNghi đã viết:
Quá hay nhưng vẫn chậm hơn Instr
Với tmpArr = Array(1, 2, 3, 4, 5, 6, 7, 8) thì dùng like hay instr sẽ nhanh hơn Dic với dữ liệu 60.000 rows.
Nhưng thay những số 1,2 ... kia thành text thì Dic nhanh hơn.
Cám ơn NDU.
Dùng Instr

PHP:

sArray = Sheet1.Range("A2:B60000").Value ReDim Arr(1 To UBound(sArray, 1), 1 To 2) tmpArr = Array(1, 2, 3, 4, 5, 6, 7, 8) Crit = Join(tmpArr, vbBack) For i = 1 To UBound(sArray, 1) Tmp = sArray(i, 1) & vbBack If InStr(Crit, Tmp) Then m = m + 1 Arr(m, 1) = sArray(i, 1) Arr(m, 2) = sArray(i, 2) End If Next

Sửa lại chổ này chút:
Crit = Join(tmpArr, vbBack) & vbBack
Nếu không sẽ mất điều kiện = 8

trungvdb · 17/2/12

Hỏi về cách viết Code chèn dòng

Tôi đang học code chèn dòng nhưng cú pháp viết chắc chưa đúng, xin chỉ giúp chỗ sai và sửa lại giúp dùm

PHP:

Sub Chendong()
Dim DL(), i As Long
DL = Range([A1], [A65000].End(xlUp)).Value
For i = UBound(DL, 1) To 1
If DL(i, 1) <> "" Then
DL(i, 1).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
End Sub

ndu96081631 · 17/2/12

trungvdb đã viết:
Tôi đang học code chèn dòng nhưng cú pháp viết chắc chưa đúng, xin chỉ giúp chỗ sai và sửa lại giúp dùm

PHP:

Sub Chendong() Dim DL(), i As Long DL = Range([A1], [A65000].End(xlUp)).Value For i = UBound(DL, 1) To 1 If DL(i, 1) <> "" Then DL(i, 1).Select Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove End If Next End Sub

Dim DL() ---> Chứng tỏ DL là mảng ---> Vậy DL(i, 1).Select là sai ---> Chỉ có Range mới Select được
For i = UBound(DL, 1) To 1 ---> Là quét ngược từ dưới lên ---> Vậy phải thêm Step -1 vào mới được (For i = UBound(DL, 1) To 1 Step -1)

trungvdb · 17/2/12

Nhờ thày Ndu mà tôi mới tỉnh ngộ được ra vấn đề, mảng là chỉ có giá trị không thôi, thiếu các thuộc tính khác như Cells, Range nên không thể Select được. Code viết đúng là

PHP:

Sub Chendong()
Dim DL As Range, i As Long
Set DL = Range([A1], [A65000].End(xlUp))
KQ = DL.Value
For i = UBound(KQ, 1) To 1 Step -1
If KQ(i, 1) <> "" Then
DL(i, 1).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
End Sub

Bỏ Select đi cho gọn

PHP:

Sub Chendong()
Dim DL As Range, i As Long
Set DL = Range([A1], [A65000].End(xlUp))
KQ = DL.Value
For i = UBound(KQ, 1) To 1 Step -1
If KQ(i, 1) <> "" Then
DL(i, 1).EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
End Sub

------------
Xin thày, mọi người chỉ bảo thêm: Khi chạy Code này những dòng mà tại đó ô cột A có dữ liệu thì nó tự động chèn dòng mới lên ngay phía trên dòng lựa chọn; nhưng nếu cần yêu cầu ngược lại dòng được chèn ở phía dưới dòng được chọn thì thay đổi Code như thế nào?

ndu96081631 · 17/2/12

trungvdb đã viết:
nhưng nếu cần yêu cầu ngược lại dòng được chèn ở phía dưới dòng được chọn thì thay đổi Code như thế nào?

Sửa vòng lập thành vầy thử xem:

Mã:

[/B]For i = UBound(KQ, 1) [COLOR=#ff0000][B]To 2[/B][/COLOR] Step -1 If [COLOR=#ff0000][B]KQ(i - 1, 1)[/B][/COLOR] <> "" Then

trungvdb · 17/2/12

Tôi chợt nghĩ ra

PHP:

Sub Chendong()
Dim DL As Range, i As Long
Set DL = Range([A1], [A65000].End(xlUp))
KQ = DL.Value
For i = UBound(KQ, 1) To 1 Step -1
If KQ(i, 1) <> "" Then
DL(i+1, 1).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
End Sub

ThuNghi · 17/2/12

trungvdb đã viết:

Tôi chợt nghĩ ra

PHP:

Sub Chendong()
Dim DL As Range, i As Long
Set DL = Range([A1], [A65000].End(xlUp))
KQ = DL.Value
For i = UBound(KQ, 1) To 1 Step -1
If KQ(i, 1) <> "" Then
DL(i+1, 1).Select
Selection.EntireRow.Insert , CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next
End Sub

Sao kg chèn vào Arr (KQ) 1 lần sau đó gán xuống sh.

PHP:

Sub Chendong2()
Dim DL, i As Long, s&
Dim KQ
DL = Range([A1], [A65000].End(xlUp)).Value
ReDim KQ(1 To UBound(DL, 1) * 2, 1 To 1)
For i = 1 To UBound(DL, 1)
  s = s + 1
  KQ(s, 1) = DL(i, 1)
  If DL(i, 1) <> "" Then
    s = s + 1
    KQ(s, 1) = ""
  End If
Next
Cells(1, 1).Resize(s) = KQ
End Sub

trungvdb · 17/2/12

Xin bái phục bác ThuNghi, cách làm của bác rất sáng tạo

(thích nhất 2 câu lệnh s=s+1 >> s=2*i của bác)

Tuy vậy, nếu ứng dụng vào thực tế (thường một bảng có nhiều cột) sẽ khiến dòng các dòng cột A sẽ bị đẩy xuống dưới, trong khi số liệu các côt khác vẫn đứng yên. Do vậy dữ liệu không còn chuẩn nữa.

viehoai · 17/2/12

Chèn mãng vào mãng
Giả sửa tôi có 2 mãng như file đính kèm
Kính nhờ các anh chi thuật toán (hoặc có code luôn càng tốt) để chèn 1 mãng thứ 2 vào mãng thứ nhất theo 1 điều kiện
Xin cảm ơn các anh chị

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

Thành viên gắn bó

Huyền thoại GPE

Chuyên gia GPE

Thành viên thường trực

Huyền thoại GPE

Thành viên tích cực

Thành viên tích cực

Hãy cho rồi sẽ nhận!

Huyền thoại GPE

Thành viên tích cực

Huyền thoại GPE

Hãy cho rồi sẽ nhận!

Huyền thoại GPE

Thành viên thường trực

Huyền thoại GPE

Thành viên thường trực

Huyền thoại GPE

Thành viên thường trực

Hãy cho rồi sẽ nhận!

Thành viên thường trực

Thành viên gắn bó

File đính kèm